+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Bug;
-
-=head1 NAME
-
-Debbugs::Bug -- OO interface to bugs
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug;
- Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-
-use DateTime;
-use List::AllUtils qw(max 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{(<src>.+)/(<ver>.+)}) { # 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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Bug::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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Bug::Tag;
-
-=head1 NAME
-
-Debbugs::Bug::Tag -- OO interface to bug tags
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug::Tag;
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-
-use Debbugs::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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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<Debbugs::CGI/splitpackages> 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(<a$class href=").
- html_escape($link).q(">).
- html_escape($link_name).q(</a>);
- }
- }
- 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(<a$class href=").
- html_escape($link).q(">).
- html_escape($link_name).q(</a>);
- }
- }
- 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(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').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{<a href="$in">} . html_escape($in) . '</a>';
- } 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(<a ${class}).
- 'href="%s">%s</a>',
- $urlfunc->($_->address),
- html_escape($_->format) ||
- '(unknown)'
- } @addrs
- );
- }
- else {
- my $prefix = (ref $prefixfunc) ?
- $prefixfunc->(1) : $prefixfunc;
- return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
- $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<Params::Validate>; 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
-
- <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
- <input type="text" name="_fo_searchkey" value="foo">
- <input type="text" name="_fo_searchvalue" value="bar">
-
-would yield foo=>'bar' in %param.
-
-=head3 concatenate
-
-Concatenate concatenates values into a single entry in a parameter
-
-For example, you would have
-
- <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
- <input type="text" name="_fo_blah" value="bar">
- <input type="text" name="_fo_bleargh" value="baz">
-
-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__
-
-
-
-
-
-
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-
-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} "<div class=\"headers\">\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(<img src=").html_escape($libravatar_url).qq(" alt="">\n);
- }
- }
- push @headers, qq(<div class="header"><span class="headerfield">$_:</span> ) . html_escape(decode_rfc1522($head_field))."</div>\n";
- }
- print {$output} join(qq(), @headers);
- } else {
- print {$output} "<pre>".html_escape(decode_rfc1522($entity->head->stringify))."</pre>\n";
- }
- print {$output} "</div>\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} '<pre class="mime">[<a href="' .
- html_escape(bug_links(bug => $ref,
- links_only => 1,
- options => {@dlargs})
- ) . qq{">$printname</a> } .
- "($type, $disposition)]</pre>\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} "<blockquote>\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} "</blockquote>\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
- }{<a href=\"$1\">$1</a>$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<a href="$config{cve_tracker}$2">$2</a>$3}gxm;
- }
- if (not exists $param{att}) {
- print {$output} qq(<pre class="$css_class">$body</pre>\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<Debbugs::Log::read_log_records>; 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 =~ /<!--\s+time:(\d+)\s+-->/;
- my $class = $text =~ /^<strong>(?: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|\.<|$)),<a href=\"$1\">$1</a>$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{(<a href="} .
- html_escape(bug_links(bug => $bug_number,
- options => {msg => ($msg_number+1)},
- links_only => 1,
- )
- ) . '">full text</a>, <a href="' .
- html_escape(bug_links(bug => $bug_number,
- options => {msg => ($msg_number+1),
- mbox => 'yes'},
- links_only => 1)
- ) . '">mbox</a>, '.
- qq{<a href="#$msg_number">link</a>).</p>};
-
- $output = qq(<div class="$class"><hr><p>\n<a name="$msg_number"></a>\n) . $output . "</p></div>\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(<hr><p class="msgreceived"><a name="$msg_number" href="#$msg_number">🔗</a>\n);
- $output .= 'View this message in <a href="' . html_escape(bug_links(bug=>$bug_number, links_only => 1, options=>{msg=>$msg_number, mbox=>'yes'})) . '">rfc822 format</a></p>';
- $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|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number"></a><a href="#$msg_number">Message #$msg_number</a> received at |.
- html_escape("$received\@$hostname") .
- q| (<a href="| . html_escape(bug_links(bug => $bug_number, links_only => 1, options => {msg=>$msg_number})) . '">full text</a>'.
- q|, <a href="| . html_escape(bug_links(bug => $bug_number,
- links_only => 1,
- options => {msg=>$msg_number,
- mbox=>'yes'}
- )
- ) .'">mbox</a>, ';
- 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(<a href=").
- html_escape('mailto:'.$bug_number.'@'.$config{email_domain}.'?'.
- join('&',map {defined $r_l->{$_}?$_.'='.uri_escape_utf8($r_l->{$_}):()} keys %{$r_l})).
- qq(">reply</a>);
-
- $output .= ')'.":</p>\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:
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-
-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} '<p>';
- print {$output} (@maint > 1? "Maintainer for $showpkg is "
- : "Maintainers for $showpkg are ") .
- package_links(maintainer => \@maint);
- print {$output} ".</p>\n";
- }
- else {
- print {$output} "<p>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. </p>\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} "<p>You may want to refer to the following packages that are part of the same source:\n";
- }
- else {
- print {$output} "<p>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 <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
- "list of other pseudo-packages</a>";
- }
- else {
- if ($package and defined $config{package_pages} and length $config{package_pages}) {
- push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
- 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 <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
- }
- # 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} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
- }
- if (@maint) {
- print {$output} "<p>If you find a bug not listed here, please\n";
- printf {$output} "<a href=\"%s\">report it</a>.</p>\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 = "<h2 class=\"outstanding\">Summary</h2>\n";
-
- if ($bugs->count == 0) {
- return "<HR><H2>No reports found!</H2></HR>\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 = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
- $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 .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 1 ] } @status ) ) . "</UL>\n";
- }
- else {
- $header .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
- if ($common{show_list_header}) {
- my $count = $count{"_$order"};
- my $bugs = $count == 1 ? "bug" : "bugs";
- $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
- }
- else {
- $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
- }
- $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
- $result .= "\n\n\n\n";
- $result .= $section{$order};
- $result .= "\n\n\n\n";
- $result .= "</UL>\n</div>\n";
- }
- $header .= "</ul></div>\n";
-
- $footer .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li>$count $param{title}[$i]->[$key]</li>\n";
- }
- if ( $local_result ) {
- $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
- }
- }
- $footer .= "</ul>\n</div>\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>^|,|\+) # joiner
- (?<field>package|tag|pending|severity) # field
- = # equals
- (?<value>[^=|\&,\+]+(?:,[^=|\&,\+])*) #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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection;
-
-=head1 NAME
-
-Debbugs::Collection -- Collection base class which can generate lots of objects
-
-=head1 SYNOPSIS
-
-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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection::Bug;
-
-=head1 NAME
-
-Debbugs::Collection::Bug -- Bug generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L<Debbugs::Collection> and contains members of
-L<Debbugs::Bug>. 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<Debbugs::Collection>
-
-=over
-
-=item package_collection
-
-Optional L<Debbugs::Collection::Package> which is used to look up packages
-
-
-=item correspondent_collection
-
-Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
-
-
-=item users
-
-Optional arrayref of L<Debbugs::User> 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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection::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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection::Package;
-
-=head1 NAME
-
-Debbugs::Collection::Package -- Package generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L<Debbugs::Collection> and contains members of
-L<Debbugs::Package>. 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<Debbugs::Collection>
-
-=over
-
-=item correspondent_collection
-
-Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
-
-
-=item versiontree
-
-Optional L<Debbugs::VersionTree> which contains known package source versions
-
-=back
-
-=head1 Methods
-
-=head2 correspondent_collection
-
- $packages->correspondent_collection
-
-Returns the L<Debbugs::Collection::Correspondent> for this package collection
-
-=head2 versiontree
-
-Returns the L<Debbugs::VersionTree> 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<Debbugs::Collection::Version> of all of the versions in this package
-collection which are known to match.
-
-Effectively, this calls L<Debbugs::Package/get_source_version_distribution> 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<Debbugs::Collection::Version> 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<Debbugs::Package/get_source_version>.
-For unqualified versions, calls L<Debbugs::Package/get_source_version>; 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{(?<src>.+?)/(?<ver>.+)$}) {
- 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<Debbugs::Package/source_names> 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<Debbugs::Collection::Package> 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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection::Version;
-
-=head1 NAME
-
-Debbugs::Collection::Version -- Version generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L<Debbugs::Collection> and contains members of
-L<Debbugs::Version>. 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<Debbugs::Collection>
-
-=over
-
-=item package_collection
-
-Optional L<Debbugs::Collection::Package> which is used to look up packages
-
-=item versions
-
-Optional arrayref of C<package/version/arch> 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:
+++ /dev/null
-# This module is part of debbugs, and is released under the terms of
-# the GPL version 3, or any later version (at your option). See the
-# file README and COPYING for more information.
-# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
-
-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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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<walk_bugs(callback => 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<dirs> and C<bugs> are
-provided, both are walked through.
-
-=item bugs_per_call -- maximum number of bugs to provide to callback
-
-=item progress_bar -- optional L<Term::ProgressBar>
-
-=item bug_file -- bug file to look for (generally C<summary>)
-
-=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<list> 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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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</web_host> and
-L</web_host_bug_dir>
-
-=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</web_domain> 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</project> 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<qw(-oem -oi)>.
-
-=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',<<END);
- <ADDRESS>$config{maintainer} <<A HREF=\"mailto:$config{maintainer_email}\">$config{maintainer_email}</A>>.
- Last modified:
- <!--timestamp-->
- SUBSTITUTE_DTIME
- <!--timestamp-->
- <P>
- <A HREF=\"$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
- Copyright (C) 1999 Darren O. Benham,
- 1997,2003 nCipher Corporation Ltd,
- 1994-97 Ian Jackson.
- </P>
- </ADDRESS>
-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;
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
-
-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<append_log> (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 .= "<!-- new_data:\n";
- my %nd;
- for my $key (keys %{$new_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- warn "No such field $key";
- next;
- }
- $nd{$key} = $new_data->{$key};
- # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
- }
- $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
- $data_diff .= "-->\n";
- $data_diff .= "<!-- old_data:\n";
- my %od;
- for my $key (keys %{$old_data}) {
- if (not exists $Debbugs::Status::fields{$key}) {
- warn "No such field $key";
- next;
- }
- $od{$key} = $old_data->{$key};
- # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
- }
- $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
- $data_diff .= "-->\n";
- }
- my $msg = join('',
- (exists $param{command} ?
- "<!-- command:".html_escape(encode_utf8_safely($param{command}))." -->\n":""
- ),
- (length $param{requester} ?
- "<!-- requester: ".html_escape(encode_utf8_safely($param{requester}))." -->\n":""
- ),
- (length $param{request_addr} ?
- "<!-- request_addr: ".html_escape(encode_utf8_safely($param{request_addr}))." -->\n":""
- ),
- "<!-- time:".time()." -->\n",
- $data_diff,
- "<strong>".html_escape(encode_utf8_safely($param{action}))."</strong>\n");
- if (length $param{requester}) {
- $msg .= "Request was from <code>".html_escape(encode_utf8_safely($param{requester}))."</code>\n";
- }
- if (length $param{request_addr}) {
- $msg .= "to <code>".html_escape(encode_utf8_safely($param{request_addr}))."</code>";
- }
- if (length $param{desc}) {
- $msg .= ":<br>\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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
-
-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<append_log> (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__
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::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:
+++ /dev/null
-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;
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-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*\<//;
- $msg_id =~ 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:
+++ /dev/null
-ColumnComment.pm
-TableComment.pm
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<arch>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<arch_arch_key>
-
-=over 4
-
-=item * L</arch>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("arch_arch_key", ["arch"]);
-
-=head1 RELATIONS
-
-=head2 bin_vers
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BinVer>
-
-=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<Debbugs::DB::Result::BugStatusCache>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bin_associations>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bin_associations_bin_suite>
-
-=over 4
-
-=item * L</bin>
-
-=item * L</suite>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bin_associations_bin_suite", ["bin", "suite"]);
-
-=head1 RELATIONS
-
-=head2 bin
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::BinVer>
-
-=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<Debbugs::DB::Result::Suite>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bin_pkg>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bin_pkg_pkg_key>
-
-=over 4
-
-=item * L</pkg>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bin_pkg_pkg_key", ["pkg"]);
-
-=head1 RELATIONS
-
-=head2 bin_pkg_src_pkgs
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BinPkgSrcPkg>
-
-=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<Debbugs::DB::Result::BinVer>
-
-=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<Debbugs::DB::Result::BugAffectsBinpackage>
-
-=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<Debbugs::DB::Result::BugBinpackage>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bin_pkg_src_pkg>
-
-=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<bin_pkg_src_pkg_bin_pkg_src_pkg>
-
-=over 4
-
-=item * L</bin_pkg>
-
-=item * L</src_pkg>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_bin_pkg_src_pkg", ["bin_pkg", "src_pkg"]);
-
-=head2 C<bin_pkg_src_pkg_src_pkg_bin_pkg>
-
-=over 4
-
-=item * L</src_pkg>
-
-=item * L</bin_pkg>
-
-=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<Debbugs::DB::Result::BinPkg>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bin_ver>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bin_ver_bin_pkg_id_arch_idx>
-
-=over 4
-
-=item * L</bin_pkg>
-
-=item * L</arch>
-
-=item * L</ver>
-
-=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<Debbugs::DB::Result::Arch>
-
-=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<Debbugs::DB::Result::BinAssociation>
-
-=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<Debbugs::DB::Result::BinPkg>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
-
-=head1 TABLE: C<binary_versions>
-
-=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(<<EOF);
-SELECT sp.pkg AS src_pkg, sv.ver AS src_ver, bp.pkg AS bin_pkg, a.arch AS arch, b.ver AS bin_ver,
-svb.ver AS src_ver_based_on, spb.pkg AS src_pkg_based_on
-FROM bin_ver b JOIN arch a ON b.arch = a.id
- JOIN bin_pkg bp ON b.bin_pkg = bp.id
- JOIN src_ver sv ON b.src_ver = sv.id
- JOIN src_pkg sp ON sv.src_pkg = sp.id
- LEFT OUTER JOIN src_ver svb ON sv.based_on = svb.id
- LEFT OUTER JOIN src_pkg spb ON spb.id = svb.src_pkg;
-EOF
-
-# You can replace this text with custom code or comments, and it will be preserved on regeneration
-1;
+++ /dev/null
-use utf8;
-package Debbugs::DB::Result::Bug;
-
-# Created by DBIx::Class::Schema::Loader
-# DO NOT MODIFY THE FIRST PART OF THIS FILE
-
-=head1 NAME
-
-Debbugs::DB::Result::Bug - Bugs
-
-=cut
-
-use strict;
-use warnings;
-
-use base 'DBIx::Class::Core';
-
-=head1 COMPONENTS LOADED
-
-=over 4
-
-=item * L<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 RELATIONS
-
-=head2 bug_affects_binpackages
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BugAffectsBinpackage>
-
-=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<Debbugs::DB::Result::BugAffectsSrcpackage>
-
-=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<Debbugs::DB::Result::BugBinpackage>
-
-=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<Debbugs::DB::Result::BugBlock>
-
-=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<Debbugs::DB::Result::BugBlock>
-
-=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<Debbugs::DB::Result::BugMerged>
-
-=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<Debbugs::DB::Result::BugMerged>
-
-=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<Debbugs::DB::Result::BugMessage>
-
-=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<Debbugs::DB::Result::BugSrcpackage>
-
-=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<Debbugs::DB::Result::BugStatusCache>
-
-=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<Debbugs::DB::Result::BugTag>
-
-=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<Debbugs::DB::Result::BugUserTag>
-
-=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<Debbugs::DB::Result::BugVer>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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<Debbugs::DB::Result::Severity>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_affects_binpackage>
-
-=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<bug_affects_binpackage_id_pkg>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</bin_pkg>
-
-=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<Debbugs::DB::Result::BinPkg>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_affects_srcpackage>
-
-=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<bug_affects_srcpackage_id_pkg>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</src_pkg>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_affects_srcpackage_id_pkg", ["bug", "src_pkg"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_binpackage>
-
-=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<bug_binpackage_bin_pkg_bug_idx>
-
-=over 4
-
-=item * L</bin_pkg>
-
-=item * L</bug>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_binpackage_bin_pkg_bug_idx", ["bin_pkg", "bug"]);
-
-=head2 C<bug_binpackage_id_pkg>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</bin_pkg>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_binpackage_id_pkg", ["bug", "bin_pkg"]);
-
-=head1 RELATIONS
-
-=head2 bin_pkg
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::BinPkg>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_blocks>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bug_blocks_bug_id_blocks_idx>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</blocks>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_blocks_bug_id_blocks_idx", ["bug", "blocks"]);
-
-=head1 RELATIONS
-
-=head2 block
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_merged>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bug_merged_bug_id_merged_idx>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</merged>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_merged_bug_id_merged_idx", ["bug", "merged"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_message>
-
-=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<bug_message_bug_message_idx>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</message>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_message_bug_message_idx", ["bug", "message"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Message>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
-
-=head1 TABLE: C<bug_package>
-
-=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(<<EOF);
-SELECT b.bug,b.bin_pkg,'binary',bp.pkg FROM bug_binpackage b JOIN bin_pkg bp ON bp.id=b.bin_pkg UNION
- SELECT s.bug,s.src_pkg,'source',sp.pkg FROM bug_srcpackage s JOIN src_pkg sp ON sp.id=s.src_pkg;
-EOF
-
-
-# You can replace this text with custom code or comments, and it will be preserved on regeneration
-1;
+++ /dev/null
-use utf8;
-package Debbugs::DB::Result::BugSrcpackage;
-
-# Created by DBIx::Class::Schema::Loader
-# DO NOT MODIFY THE FIRST PART OF THIS FILE
-
-=head1 NAME
-
-Debbugs::DB::Result::BugSrcpackage - Bug <-> source package mapping
-
-=cut
-
-use strict;
-use warnings;
-
-use base 'DBIx::Class::Core';
-
-=head1 COMPONENTS LOADED
-
-=over 4
-
-=item * L<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_srcpackage>
-
-=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<bug_srcpackage_id_pkg>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</src_pkg>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_srcpackage_id_pkg", ["bug", "src_pkg"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
-
-=head1 TABLE: C<bug_status>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_status_cache>
-
-=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<bug_status_cache_bug_suite_arch_idx>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</suite>
-
-=item * L</arch>
-
-=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<Debbugs::DB::Result::Arch>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Suite>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_tag>
-
-=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<bug_tag_bug_tag>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</tag>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_tag_bug_tag", ["bug", "tag"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Tag>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_user_tag>
-
-=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<bug_user_tag_bug_tag>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</user_tag>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("bug_user_tag_bug_tag", ["bug", "user_tag"]);
-
-=head1 RELATIONS
-
-=head2 bug
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::UserTag>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<bug_ver>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<bug_ver_bug_ver_string_found_idx>
-
-=over 4
-
-=item * L</bug>
-
-=item * L</ver_string>
-
-=item * L</found>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<correspondent>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<correspondent_addr_idx>
-
-=over 4
-
-=item * L</addr>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("correspondent_addr_idx", ["addr"]);
-
-=head1 RELATIONS
-
-=head2 bug_owners
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::Bug>
-
-=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<Debbugs::DB::Result::CorrespondentFullName>
-
-=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<Debbugs::DB::Result::Maintainer>
-
-=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<Debbugs::DB::Result::MessageCorrespondent>
-
-=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<Debbugs::DB::Result::UserTag>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<correspondent_full_name>
-
-=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<correspondent_full_name_correspondent_full_name_idx>
-
-=over 4
-
-=item * L</correspondent>
-
-=item * L</full_name>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<maintainer>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<maintainer_name_idx>
-
-=over 4
-
-=item * L</name>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("maintainer_name_idx", ["name"]);
-
-=head1 RELATIONS
-
-=head2 correspondent
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Correspondent>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<message>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<message_msgid_from_complete_to_complete_subject_idx>
-
-=over 4
-
-=item * L</msgid>
-
-=item * L</from_complete>
-
-=item * L</to_complete>
-
-=item * L</subject>
-
-=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<Debbugs::DB::Result::BugMessage>
-
-=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<Debbugs::DB::Result::MessageCorrespondent>
-
-=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<Debbugs::DB::Result::MessageRef>
-
-=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<Debbugs::DB::Result::MessageRef>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<message_correspondent>
-
-=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<message_correspondent_message_correspondent_correspondent_t_idx>
-
-=over 4
-
-=item * L</message>
-
-=item * L</correspondent>
-
-=item * L</correspondent_type>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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<Debbugs::DB::Result::Message>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<message_refs>
-
-=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<message_refs_message_refs_idx>
-
-=over 4
-
-=item * L</message>
-
-=item * L</refs>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("message_refs_message_refs_idx", ["message", "refs"]);
-
-=head1 RELATIONS
-
-=head2 message
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::Message>
-
-=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<Debbugs::DB::Result::Message>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<severity>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<severity_severity_idx>
-
-=over 4
-
-=item * L</severity>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("severity_severity_idx", ["severity"]);
-
-=head1 RELATIONS
-
-=head2 bugs
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::Bug>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<src_associations>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<src_associations_source_suite>
-
-=over 4
-
-=item * L</source>
-
-=item * L</suite>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("src_associations_source_suite", ["source", "suite"]);
-
-=head1 RELATIONS
-
-=head2 source
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::SrcVer>
-
-=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<Debbugs::DB::Result::Suite>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<src_pkg>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<src_pkg_pkg_disabled>
-
-=over 4
-
-=item * L</pkg>
-
-=item * L</disabled>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("src_pkg_pkg_disabled", ["pkg", "disabled"]);
-
-=head1 RELATIONS
-
-=head2 alias_of
-
-Type: belongs_to
-
-Related object: L<Debbugs::DB::Result::SrcPkg>
-
-=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<Debbugs::DB::Result::BinPkgSrcPkg>
-
-=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<Debbugs::DB::Result::BugAffectsSrcpackage>
-
-=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<Debbugs::DB::Result::BugSrcpackage>
-
-=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<Debbugs::DB::Result::BugVer>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<src_ver>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<src_ver_src_pkg_id_ver>
-
-=over 4
-
-=item * L</src_pkg>
-
-=item * L</ver>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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<Debbugs::DB::Result::BinVer>
-
-=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<Debbugs::DB::Result::BugVer>
-
-=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<Debbugs::DB::Result::Maintainer>
-
-=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<Debbugs::DB::Result::SrcAssociation>
-
-=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<Debbugs::DB::Result::SrcPkg>
-
-=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<Debbugs::DB::Result::SrcVer>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<suite>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<suite_idx_codename>
-
-=over 4
-
-=item * L</codename>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("suite_idx_codename", ["codename"]);
-
-=head2 C<suite_idx_version>
-
-=over 4
-
-=item * L</version>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("suite_idx_version", ["version"]);
-
-=head2 C<suite_suite_name_key>
-
-=over 4
-
-=item * L</suite_name>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("suite_suite_name_key", ["suite_name"]);
-
-=head1 RELATIONS
-
-=head2 bin_associations
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BinAssociation>
-
-=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<Debbugs::DB::Result::BugStatusCache>
-
-=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<Debbugs::DB::Result::SrcAssociation>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<tag>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<tag_tag_key>
-
-=over 4
-
-=item * L</tag>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("tag_tag_key", ["tag"]);
-
-=head1 RELATIONS
-
-=head2 bug_tags
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BugTag>
-
-=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;
+++ /dev/null
-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<DBIx::Class::InflateColumn::DateTime>
-
-=item * L<DBIx::Class::TimeStamp>
-
-=back
-
-=cut
-
-__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
-
-=head1 TABLE: C<user_tag>
-
-=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</id>
-
-=back
-
-=cut
-
-__PACKAGE__->set_primary_key("id");
-
-=head1 UNIQUE CONSTRAINTS
-
-=head2 C<user_tag_tag_correspondent>
-
-=over 4
-
-=item * L</tag>
-
-=item * L</correspondent>
-
-=back
-
-=cut
-
-__PACKAGE__->add_unique_constraint("user_tag_tag_correspondent", ["tag", "correspondent"]);
-
-=head1 RELATIONS
-
-=head2 bug_user_tags
-
-Type: has_many
-
-Related object: L<Debbugs::DB::Result::BugUserTag>
-
-=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<Debbugs::DB::Result::Correspondent>
-
-=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;
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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<Debbugs::DB::Load::load_bug> 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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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 =~ /</) {
- $addr = getparsedaddrs($addr);
- $full_name = $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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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 <baz@example.com>')
-
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-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__
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
-
-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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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__
-
-
-
-
-
-
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-package Debbugs::Libravatar;
-
-=head1 NAME
-
-Debbugs::Libravatar -- Libravatar service handler (mod_perl)
-
-=head1 SYNOPSIS
-
-<Location /libravatar>
- SetHandler perl-script
- PerlResponseHandler Debbugs::Libravatar
-</Location>
-
-=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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2004 by Collin Watson <cjwatson@debian.org>
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>
-
-
-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<type> field is C<incoming-recv>, C<autocheck>,
-C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
-C<[html]> as above; C<recips> 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:
+++ /dev/null
-# This module is part of debbugs, and is released under the terms of the GPL
-# version 2, or any later version (at your option). See the file README and
-# COPYING for more information.
-#
-# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
-
-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
-
-C<next if ($spam_log->is_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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
-
-
-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?= <don@donarmstrong.com>')
-
-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 <don@donarmstrong.com>')
-
-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;
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2004-7 by Don Armstrong <don@donarmstrong.com>.
-
-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 => <<END, recipients=>[@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'} = "<handler.${bug_num}.${nn}.$param{msgtype}\@$config{email_domain}>";
- 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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::OOBase;
-
-=head1 NAME
-
-Debbugs::OOBase -- OO Base class for Debbugs
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::autoclean;
-
-has schema => (is => 'ro', isa => 'Object',
- required => 0,
- predicate => 'has_schema',
- );
-
-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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::OOTypes;
-
-=head1 NAME
-
-Debbugs::OOTypes -- OO Types for Debbugs
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse::Util::TypeConstraints;
-use strictures 2;
-use namespace::autoclean;
-
-# Bug Subtype
-subtype 'Bug' =>
- as 'Debbugs::Bug';
-
-coerce 'Bug' =>
- from 'Int' =>
- via {Debbugs::Bug->new($_)};
-
-# Package Subtype
-subtype 'Package' =>
- as 'Debbugs::Package';
-
-coerce 'Package' =>
- from 'Str' =>
- via {Debbugs::Package->new(package => $_)};
-
-
-# Version Subtype
-subtype 'Version' =>
- as 'Debbugs::Version';
-
-coerce 'Version' =>
- from 'Str' =>
- via {Debbugs::Version->new(string=>$_)};
-
-no Mouse::Util::TypeConstraints;
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 3, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Package;
-
-=head1 NAME
-
-Debbugs::Package -- OO interface to packages
-
-=head1 SYNOPSIS
-
- use Debbugs::Package;
- Debbugs::Package->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use 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<src:> 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<binary> or C<source>
-
-=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<Debbugs::Collection::Correspondent> 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<Debbugs::Collection::Package> 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<Debbugs::Collection::Correspondent> 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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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;
+++ /dev/null
-# 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 <don@donarmstrong.com>.
-# $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<bcc>, C<cc>, or C<to>, 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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later version at your option.
-# See the file README and COPYING for more information.
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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<Debbugs::Status::get_bug_status> 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<Debbugs::Status::get_bug_status> 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<Debbugs::Bugs::get_bugs> 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<Debbugs::Packages::binary_to_source> 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<Debbugs::Packages::sourcetobinary>)
-
-=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<Debbugs::Packages::get_versions>
-
-=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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later version at your option.
-# See the file README and COPYING for more information.
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
-
-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</getbugcomponent>
-
-=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<must> call
-C<unfilelock();> 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<bug> or C<summary> 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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-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(<option value=").html_escape($o_value).qq("$selected>).
- html_escape($name).qq(</option>\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;
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::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;
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-# 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<URI> 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<URI> 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__
-
-
-
-
-
-
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
-
-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__
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2004 by Anthony Towns
-# Copyright 2008 by Don Armstrong <don@donarmstrong.com>
-
-
-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__
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Version;
-
-=head1 NAME
-
-Debbugs::Version -- OO interface to Version
-
-=head1 SYNOPSIS
-
-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 C<Debbugs::Version::Binary->new(%params|$param)> for a binary version
-
-=over
-
-=item schema
-
-L<Debbugs::DB> schema which can be used to look up versions
-
-=item package
-
-String representation of the package
-
-=item pkg
-
-L<Debbugs::Package> which refers to the package given.
-
-Only one of C<package> or C<pkg> should be given
-
-=item package_collection
-
-L<Debbugs::Collection::Package> which is used to generate a L<Debbugs::Package>
-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<Debbugs::Package> object corresponding to C<package>.
-
-=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<Debugs::Collection::Package> 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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Version::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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Version::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:
+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::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:
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [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<sort>
-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<ancestor> and C<descendant>. Returns true if and only
-if C<ancestor> is a version on which C<descendant> 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<merge> 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<load>
-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<version>, C<found>, and C<fixed>. Returns true if
-and only if C<version> is based on or equal to a version in the list
-referenced by C<found>, and not based on or equal to one referenced by
-C<fixed>.
-
-C<buggy> 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<found> and C<fixed>, which are interpreted as in
-L</buggy>. 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</buggy>). If
-you pass a third argument, C<interested>, this method will stop after
-determining the state of the bug at all the versions listed therein.
-
-Whether this is faster than calling L</buggy> 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;
+++ /dev/null
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright Colin Watson <cjwatson@debian.org>
-# Copyright Ian Jackson <iwj@debian.org>
-# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
-
-
-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 <don@donarmstrong.com> and Colin Watson
-E<lt>cjwatson@debian.orgE<gt>, based on the implementation in
-C<dpkg/lib/vercmp.c> by Ian Jackson and others.
-
-=cut
-
-1;
+++ /dev/null
-# 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;
$(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
use ExtUtils::MakeMaker;
WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl',
- PMLIBDIRS => ['Debbugs','Mail'],
EXE_FILES => ['bin/local-debbugs',
'bin/add_bug_to_estraier',
],
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Bug;
+
+=head1 NAME
+
+Debbugs::Bug -- OO interface to bugs
+
+=head1 SYNOPSIS
+
+ use Debbugs::Bug;
+ Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use Mouse;
+use strictures 2;
+use namespace::clean;
+use v5.10; # for state
+
+use DateTime;
+use List::AllUtils qw(max 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{(<src>.+)/(<ver>.+)}) { # 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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Bug::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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Bug::Tag;
+
+=head1 NAME
+
+Debbugs::Bug::Tag -- OO interface to bug tags
+
+=head1 SYNOPSIS
+
+ use Debbugs::Bug::Tag;
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use Mouse;
+use strictures 2;
+use namespace::clean;
+use v5.10; # for state
+
+use Debbugs::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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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<Debbugs::CGI/splitpackages> 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(<a$class href=").
+ html_escape($link).q(">).
+ html_escape($link_name).q(</a>);
+ }
+ }
+ 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(<a$class href=").
+ html_escape($link).q(">).
+ html_escape($link_name).q(</a>);
+ }
+ }
+ 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(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').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{<a href="$in">} . html_escape($in) . '</a>';
+ } 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(<a ${class}).
+ 'href="%s">%s</a>',
+ $urlfunc->($_->address),
+ html_escape($_->format) ||
+ '(unknown)'
+ } @addrs
+ );
+ }
+ else {
+ my $prefix = (ref $prefixfunc) ?
+ $prefixfunc->(1) : $prefixfunc;
+ return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
+ $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<Params::Validate>; 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
+
+ <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_searchkey" value="foo">
+ <input type="text" name="_fo_searchvalue" value="bar">
+
+would yield foo=>'bar' in %param.
+
+=head3 concatenate
+
+Concatenate concatenates values into a single entry in a parameter
+
+For example, you would have
+
+ <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_blah" value="bar">
+ <input type="text" name="_fo_bleargh" value="baz">
+
+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__
+
+
+
+
+
+
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+
+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} "<div class=\"headers\">\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(<img src=").html_escape($libravatar_url).qq(" alt="">\n);
+ }
+ }
+ push @headers, qq(<div class="header"><span class="headerfield">$_:</span> ) . html_escape(decode_rfc1522($head_field))."</div>\n";
+ }
+ print {$output} join(qq(), @headers);
+ } else {
+ print {$output} "<pre>".html_escape(decode_rfc1522($entity->head->stringify))."</pre>\n";
+ }
+ print {$output} "</div>\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} '<pre class="mime">[<a href="' .
+ html_escape(bug_links(bug => $ref,
+ links_only => 1,
+ options => {@dlargs})
+ ) . qq{">$printname</a> } .
+ "($type, $disposition)]</pre>\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} "<blockquote>\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} "</blockquote>\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
+ }{<a href=\"$1\">$1</a>$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<a href="$config{cve_tracker}$2">$2</a>$3}gxm;
+ }
+ if (not exists $param{att}) {
+ print {$output} qq(<pre class="$css_class">$body</pre>\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<Debbugs::Log::read_log_records>; 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 =~ /<!--\s+time:(\d+)\s+-->/;
+ my $class = $text =~ /^<strong>(?: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|\.<|$)),<a href=\"$1\">$1</a>$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{(<a href="} .
+ html_escape(bug_links(bug => $bug_number,
+ options => {msg => ($msg_number+1)},
+ links_only => 1,
+ )
+ ) . '">full text</a>, <a href="' .
+ html_escape(bug_links(bug => $bug_number,
+ options => {msg => ($msg_number+1),
+ mbox => 'yes'},
+ links_only => 1)
+ ) . '">mbox</a>, '.
+ qq{<a href="#$msg_number">link</a>).</p>};
+
+ $output = qq(<div class="$class"><hr><p>\n<a name="$msg_number"></a>\n) . $output . "</p></div>\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(<hr><p class="msgreceived"><a name="$msg_number" href="#$msg_number">🔗</a>\n);
+ $output .= 'View this message in <a href="' . html_escape(bug_links(bug=>$bug_number, links_only => 1, options=>{msg=>$msg_number, mbox=>'yes'})) . '">rfc822 format</a></p>';
+ $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|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number"></a><a href="#$msg_number">Message #$msg_number</a> received at |.
+ html_escape("$received\@$hostname") .
+ q| (<a href="| . html_escape(bug_links(bug => $bug_number, links_only => 1, options => {msg=>$msg_number})) . '">full text</a>'.
+ q|, <a href="| . html_escape(bug_links(bug => $bug_number,
+ links_only => 1,
+ options => {msg=>$msg_number,
+ mbox=>'yes'}
+ )
+ ) .'">mbox</a>, ';
+ 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(<a href=").
+ html_escape('mailto:'.$bug_number.'@'.$config{email_domain}.'?'.
+ join('&',map {defined $r_l->{$_}?$_.'='.uri_escape_utf8($r_l->{$_}):()} keys %{$r_l})).
+ qq(">reply</a>);
+
+ $output .= ')'.":</p>\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:
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+
+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} '<p>';
+ print {$output} (@maint > 1? "Maintainer for $showpkg is "
+ : "Maintainers for $showpkg are ") .
+ package_links(maintainer => \@maint);
+ print {$output} ".</p>\n";
+ }
+ else {
+ print {$output} "<p>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. </p>\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} "<p>You may want to refer to the following packages that are part of the same source:\n";
+ }
+ else {
+ print {$output} "<p>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 <a href=\"$config{web_domain}/pseudo-packages$config{html_suffix}\">".
+ "list of other pseudo-packages</a>";
+ }
+ else {
+ if ($package and defined $config{package_pages} and length $config{package_pages}) {
+ push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
+ 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 <a href=").html_escape("$config{package_tracking_domain}/$ptslink").q(">Package Tracking System</a>);
+ }
+ # 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} "<p>You might like to refer ", join(", ", @references), ".</p>\n";
+ }
+ if (@maint) {
+ print {$output} "<p>If you find a bug not listed here, please\n";
+ printf {$output} "<a href=\"%s\">report it</a>.</p>\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 = "<h2 class=\"outstanding\">Summary</h2>\n";
+
+ if ($bugs->count == 0) {
+ return "<HR><H2>No reports found!</H2></HR>\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 = "<li>"; #<a href=\"%s\">#%d: %s</a>\n<br>",
+ $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 .= "<UL class=\"bugs\">\n" . join("", map( { $_->[ 1 ] } @status ) ) . "</UL>\n";
+ }
+ else {
+ $header .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li><a href=\"#$order\">$title</a> ($count $bugs)</li>\n";
+ if ($common{show_list_header}) {
+ my $count = $count{"_$order"};
+ my $bugs = $count == 1 ? "bug" : "bugs";
+ $result .= "<H2 CLASS=\"outstanding\"><a name=\"$order\"></a>$title ($count $bugs)</H2>\n";
+ }
+ else {
+ $result .= "<H2 CLASS=\"outstanding\">$title</H2>\n";
+ }
+ $result .= "<div class=\"msgreceived\">\n<UL class=\"bugs\">\n";
+ $result .= "\n\n\n\n";
+ $result .= $section{$order};
+ $result .= "\n\n\n\n";
+ $result .= "</UL>\n</div>\n";
+ }
+ $header .= "</ul></div>\n";
+
+ $footer .= "<div class=\"msgreceived\">\n<ul>\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 .= "<li>$count $param{title}[$i]->[$key]</li>\n";
+ }
+ if ( $local_result ) {
+ $footer .= "<li>$param{names}[$i]<ul>\n$local_result</ul></li>\n";
+ }
+ }
+ $footer .= "</ul>\n</div>\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>^|,|\+) # joiner
+ (?<field>package|tag|pending|severity) # field
+ = # equals
+ (?<value>[^=|\&,\+]+(?:,[^=|\&,\+])*) #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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Collection;
+
+=head1 NAME
+
+Debbugs::Collection -- Collection base class which can generate lots of objects
+
+=head1 SYNOPSIS
+
+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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Collection::Bug;
+
+=head1 NAME
+
+Debbugs::Collection::Bug -- Bug generation factory
+
+=head1 SYNOPSIS
+
+This collection extends L<Debbugs::Collection> and contains members of
+L<Debbugs::Bug>. 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<Debbugs::Collection>
+
+=over
+
+=item package_collection
+
+Optional L<Debbugs::Collection::Package> which is used to look up packages
+
+
+=item correspondent_collection
+
+Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
+
+
+=item users
+
+Optional arrayref of L<Debbugs::User> 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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Collection::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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Collection::Package;
+
+=head1 NAME
+
+Debbugs::Collection::Package -- Package generation factory
+
+=head1 SYNOPSIS
+
+This collection extends L<Debbugs::Collection> and contains members of
+L<Debbugs::Package>. 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<Debbugs::Collection>
+
+=over
+
+=item correspondent_collection
+
+Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
+
+
+=item versiontree
+
+Optional L<Debbugs::VersionTree> which contains known package source versions
+
+=back
+
+=head1 Methods
+
+=head2 correspondent_collection
+
+ $packages->correspondent_collection
+
+Returns the L<Debbugs::Collection::Correspondent> for this package collection
+
+=head2 versiontree
+
+Returns the L<Debbugs::VersionTree> 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<Debbugs::Collection::Version> of all of the versions in this package
+collection which are known to match.
+
+Effectively, this calls L<Debbugs::Package/get_source_version_distribution> 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<Debbugs::Collection::Version> 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<Debbugs::Package/get_source_version>.
+For unqualified versions, calls L<Debbugs::Package/get_source_version>; 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{(?<src>.+?)/(?<ver>.+)$}) {
+ 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<Debbugs::Package/source_names> 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<Debbugs::Collection::Package> 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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Collection::Version;
+
+=head1 NAME
+
+Debbugs::Collection::Version -- Version generation factory
+
+=head1 SYNOPSIS
+
+This collection extends L<Debbugs::Collection> and contains members of
+L<Debbugs::Version>. 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<Debbugs::Collection>
+
+=over
+
+=item package_collection
+
+Optional L<Debbugs::Collection::Package> which is used to look up packages
+
+=item versions
+
+Optional arrayref of C<package/version/arch> 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:
--- /dev/null
+# This module is part of debbugs, and is released under the terms of
+# the GPL version 3, or any later version (at your option). See the
+# file README and COPYING for more information.
+# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
+
+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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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<walk_bugs(callback => 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<dirs> and C<bugs> are
+provided, both are walked through.
+
+=item bugs_per_call -- maximum number of bugs to provide to callback
+
+=item progress_bar -- optional L<Term::ProgressBar>
+
+=item bug_file -- bug file to look for (generally C<summary>)
+
+=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<list> 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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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</web_host> and
+L</web_host_bug_dir>
+
+=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</web_domain> 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</project> 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<qw(-oem -oi)>.
+
+=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',<<END);
+ <ADDRESS>$config{maintainer} <<A HREF=\"mailto:$config{maintainer_email}\">$config{maintainer_email}</A>>.
+ Last modified:
+ <!--timestamp-->
+ SUBSTITUTE_DTIME
+ <!--timestamp-->
+ <P>
+ <A HREF=\"$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
+ Copyright (C) 1999 Darren O. Benham,
+ 1997,2003 nCipher Corporation Ltd,
+ 1994-97 Ian Jackson.
+ </P>
+ </ADDRESS>
+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;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
+
+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<append_log> (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 .= "<!-- new_data:\n";
+ my %nd;
+ for my $key (keys %{$new_data}) {
+ if (not exists $Debbugs::Status::fields{$key}) {
+ warn "No such field $key";
+ next;
+ }
+ $nd{$key} = $new_data->{$key};
+ # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
+ }
+ $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
+ $data_diff .= "-->\n";
+ $data_diff .= "<!-- old_data:\n";
+ my %od;
+ for my $key (keys %{$old_data}) {
+ if (not exists $Debbugs::Status::fields{$key}) {
+ warn "No such field $key";
+ next;
+ }
+ $od{$key} = $old_data->{$key};
+ # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
+ }
+ $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
+ $data_diff .= "-->\n";
+ }
+ my $msg = join('',
+ (exists $param{command} ?
+ "<!-- command:".html_escape(encode_utf8_safely($param{command}))." -->\n":""
+ ),
+ (length $param{requester} ?
+ "<!-- requester: ".html_escape(encode_utf8_safely($param{requester}))." -->\n":""
+ ),
+ (length $param{request_addr} ?
+ "<!-- request_addr: ".html_escape(encode_utf8_safely($param{request_addr}))." -->\n":""
+ ),
+ "<!-- time:".time()." -->\n",
+ $data_diff,
+ "<strong>".html_escape(encode_utf8_safely($param{action}))."</strong>\n");
+ if (length $param{requester}) {
+ $msg .= "Request was from <code>".html_escape(encode_utf8_safely($param{requester}))."</code>\n";
+ }
+ if (length $param{request_addr}) {
+ $msg .= "to <code>".html_escape(encode_utf8_safely($param{request_addr}))."</code>";
+ }
+ if (length $param{desc}) {
+ $msg .= ":<br>\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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
+
+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<append_log> (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__
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::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:
--- /dev/null
+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;
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+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*\<//;
+ $msg_id =~ 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:
--- /dev/null
+ColumnComment.pm
+TableComment.pm
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<arch>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<arch_arch_key>
+
+=over 4
+
+=item * L</arch>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("arch_arch_key", ["arch"]);
+
+=head1 RELATIONS
+
+=head2 bin_vers
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BinVer>
+
+=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<Debbugs::DB::Result::BugStatusCache>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bin_associations>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bin_associations_bin_suite>
+
+=over 4
+
+=item * L</bin>
+
+=item * L</suite>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bin_associations_bin_suite", ["bin", "suite"]);
+
+=head1 RELATIONS
+
+=head2 bin
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::BinVer>
+
+=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<Debbugs::DB::Result::Suite>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bin_pkg>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bin_pkg_pkg_key>
+
+=over 4
+
+=item * L</pkg>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bin_pkg_pkg_key", ["pkg"]);
+
+=head1 RELATIONS
+
+=head2 bin_pkg_src_pkgs
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BinPkgSrcPkg>
+
+=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<Debbugs::DB::Result::BinVer>
+
+=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<Debbugs::DB::Result::BugAffectsBinpackage>
+
+=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<Debbugs::DB::Result::BugBinpackage>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bin_pkg_src_pkg>
+
+=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<bin_pkg_src_pkg_bin_pkg_src_pkg>
+
+=over 4
+
+=item * L</bin_pkg>
+
+=item * L</src_pkg>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_bin_pkg_src_pkg", ["bin_pkg", "src_pkg"]);
+
+=head2 C<bin_pkg_src_pkg_src_pkg_bin_pkg>
+
+=over 4
+
+=item * L</src_pkg>
+
+=item * L</bin_pkg>
+
+=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<Debbugs::DB::Result::BinPkg>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bin_ver>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bin_ver_bin_pkg_id_arch_idx>
+
+=over 4
+
+=item * L</bin_pkg>
+
+=item * L</arch>
+
+=item * L</ver>
+
+=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<Debbugs::DB::Result::Arch>
+
+=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<Debbugs::DB::Result::BinAssociation>
+
+=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<Debbugs::DB::Result::BinPkg>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
+
+=head1 TABLE: C<binary_versions>
+
+=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(<<EOF);
+SELECT sp.pkg AS src_pkg, sv.ver AS src_ver, bp.pkg AS bin_pkg, a.arch AS arch, b.ver AS bin_ver,
+svb.ver AS src_ver_based_on, spb.pkg AS src_pkg_based_on
+FROM bin_ver b JOIN arch a ON b.arch = a.id
+ JOIN bin_pkg bp ON b.bin_pkg = bp.id
+ JOIN src_ver sv ON b.src_ver = sv.id
+ JOIN src_pkg sp ON sv.src_pkg = sp.id
+ LEFT OUTER JOIN src_ver svb ON sv.based_on = svb.id
+ LEFT OUTER JOIN src_pkg spb ON spb.id = svb.src_pkg;
+EOF
+
+# You can replace this text with custom code or comments, and it will be preserved on regeneration
+1;
--- /dev/null
+use utf8;
+package Debbugs::DB::Result::Bug;
+
+# Created by DBIx::Class::Schema::Loader
+# DO NOT MODIFY THE FIRST PART OF THIS FILE
+
+=head1 NAME
+
+Debbugs::DB::Result::Bug - Bugs
+
+=cut
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=head1 COMPONENTS LOADED
+
+=over 4
+
+=item * L<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 RELATIONS
+
+=head2 bug_affects_binpackages
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BugAffectsBinpackage>
+
+=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<Debbugs::DB::Result::BugAffectsSrcpackage>
+
+=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<Debbugs::DB::Result::BugBinpackage>
+
+=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<Debbugs::DB::Result::BugBlock>
+
+=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<Debbugs::DB::Result::BugBlock>
+
+=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<Debbugs::DB::Result::BugMerged>
+
+=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<Debbugs::DB::Result::BugMerged>
+
+=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<Debbugs::DB::Result::BugMessage>
+
+=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<Debbugs::DB::Result::BugSrcpackage>
+
+=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<Debbugs::DB::Result::BugStatusCache>
+
+=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<Debbugs::DB::Result::BugTag>
+
+=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<Debbugs::DB::Result::BugUserTag>
+
+=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<Debbugs::DB::Result::BugVer>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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<Debbugs::DB::Result::Severity>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_affects_binpackage>
+
+=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<bug_affects_binpackage_id_pkg>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</bin_pkg>
+
+=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<Debbugs::DB::Result::BinPkg>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_affects_srcpackage>
+
+=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<bug_affects_srcpackage_id_pkg>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</src_pkg>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_affects_srcpackage_id_pkg", ["bug", "src_pkg"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_binpackage>
+
+=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<bug_binpackage_bin_pkg_bug_idx>
+
+=over 4
+
+=item * L</bin_pkg>
+
+=item * L</bug>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_binpackage_bin_pkg_bug_idx", ["bin_pkg", "bug"]);
+
+=head2 C<bug_binpackage_id_pkg>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</bin_pkg>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_binpackage_id_pkg", ["bug", "bin_pkg"]);
+
+=head1 RELATIONS
+
+=head2 bin_pkg
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::BinPkg>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_blocks>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bug_blocks_bug_id_blocks_idx>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</blocks>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_blocks_bug_id_blocks_idx", ["bug", "blocks"]);
+
+=head1 RELATIONS
+
+=head2 block
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_merged>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bug_merged_bug_id_merged_idx>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</merged>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_merged_bug_id_merged_idx", ["bug", "merged"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_message>
+
+=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<bug_message_bug_message_idx>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</message>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_message_bug_message_idx", ["bug", "message"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Message>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
+
+=head1 TABLE: C<bug_package>
+
+=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(<<EOF);
+SELECT b.bug,b.bin_pkg,'binary',bp.pkg FROM bug_binpackage b JOIN bin_pkg bp ON bp.id=b.bin_pkg UNION
+ SELECT s.bug,s.src_pkg,'source',sp.pkg FROM bug_srcpackage s JOIN src_pkg sp ON sp.id=s.src_pkg;
+EOF
+
+
+# You can replace this text with custom code or comments, and it will be preserved on regeneration
+1;
--- /dev/null
+use utf8;
+package Debbugs::DB::Result::BugSrcpackage;
+
+# Created by DBIx::Class::Schema::Loader
+# DO NOT MODIFY THE FIRST PART OF THIS FILE
+
+=head1 NAME
+
+Debbugs::DB::Result::BugSrcpackage - Bug <-> source package mapping
+
+=cut
+
+use strict;
+use warnings;
+
+use base 'DBIx::Class::Core';
+
+=head1 COMPONENTS LOADED
+
+=over 4
+
+=item * L<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_srcpackage>
+
+=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<bug_srcpackage_id_pkg>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</src_pkg>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_srcpackage_id_pkg", ["bug", "src_pkg"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+__PACKAGE__->table_class("DBIx::Class::ResultSource::View");
+
+=head1 TABLE: C<bug_status>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_status_cache>
+
+=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<bug_status_cache_bug_suite_arch_idx>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</suite>
+
+=item * L</arch>
+
+=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<Debbugs::DB::Result::Arch>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Suite>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_tag>
+
+=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<bug_tag_bug_tag>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</tag>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_tag_bug_tag", ["bug", "tag"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Tag>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_user_tag>
+
+=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<bug_user_tag_bug_tag>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</user_tag>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("bug_user_tag_bug_tag", ["bug", "user_tag"]);
+
+=head1 RELATIONS
+
+=head2 bug
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::UserTag>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<bug_ver>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<bug_ver_bug_ver_string_found_idx>
+
+=over 4
+
+=item * L</bug>
+
+=item * L</ver_string>
+
+=item * L</found>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<correspondent>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<correspondent_addr_idx>
+
+=over 4
+
+=item * L</addr>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("correspondent_addr_idx", ["addr"]);
+
+=head1 RELATIONS
+
+=head2 bug_owners
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::Bug>
+
+=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<Debbugs::DB::Result::CorrespondentFullName>
+
+=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<Debbugs::DB::Result::Maintainer>
+
+=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<Debbugs::DB::Result::MessageCorrespondent>
+
+=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<Debbugs::DB::Result::UserTag>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<correspondent_full_name>
+
+=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<correspondent_full_name_correspondent_full_name_idx>
+
+=over 4
+
+=item * L</correspondent>
+
+=item * L</full_name>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<maintainer>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<maintainer_name_idx>
+
+=over 4
+
+=item * L</name>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("maintainer_name_idx", ["name"]);
+
+=head1 RELATIONS
+
+=head2 correspondent
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Correspondent>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<message>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<message_msgid_from_complete_to_complete_subject_idx>
+
+=over 4
+
+=item * L</msgid>
+
+=item * L</from_complete>
+
+=item * L</to_complete>
+
+=item * L</subject>
+
+=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<Debbugs::DB::Result::BugMessage>
+
+=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<Debbugs::DB::Result::MessageCorrespondent>
+
+=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<Debbugs::DB::Result::MessageRef>
+
+=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<Debbugs::DB::Result::MessageRef>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<message_correspondent>
+
+=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<message_correspondent_message_correspondent_correspondent_t_idx>
+
+=over 4
+
+=item * L</message>
+
+=item * L</correspondent>
+
+=item * L</correspondent_type>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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<Debbugs::DB::Result::Message>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<message_refs>
+
+=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<message_refs_message_refs_idx>
+
+=over 4
+
+=item * L</message>
+
+=item * L</refs>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("message_refs_message_refs_idx", ["message", "refs"]);
+
+=head1 RELATIONS
+
+=head2 message
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::Message>
+
+=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<Debbugs::DB::Result::Message>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<severity>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<severity_severity_idx>
+
+=over 4
+
+=item * L</severity>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("severity_severity_idx", ["severity"]);
+
+=head1 RELATIONS
+
+=head2 bugs
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::Bug>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<src_associations>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<src_associations_source_suite>
+
+=over 4
+
+=item * L</source>
+
+=item * L</suite>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("src_associations_source_suite", ["source", "suite"]);
+
+=head1 RELATIONS
+
+=head2 source
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::SrcVer>
+
+=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<Debbugs::DB::Result::Suite>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<src_pkg>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<src_pkg_pkg_disabled>
+
+=over 4
+
+=item * L</pkg>
+
+=item * L</disabled>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("src_pkg_pkg_disabled", ["pkg", "disabled"]);
+
+=head1 RELATIONS
+
+=head2 alias_of
+
+Type: belongs_to
+
+Related object: L<Debbugs::DB::Result::SrcPkg>
+
+=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<Debbugs::DB::Result::BinPkgSrcPkg>
+
+=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<Debbugs::DB::Result::BugAffectsSrcpackage>
+
+=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<Debbugs::DB::Result::BugSrcpackage>
+
+=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<Debbugs::DB::Result::BugVer>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<src_ver>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<src_ver_src_pkg_id_ver>
+
+=over 4
+
+=item * L</src_pkg>
+
+=item * L</ver>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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<Debbugs::DB::Result::BinVer>
+
+=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<Debbugs::DB::Result::BugVer>
+
+=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<Debbugs::DB::Result::Maintainer>
+
+=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<Debbugs::DB::Result::SrcAssociation>
+
+=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<Debbugs::DB::Result::SrcPkg>
+
+=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<Debbugs::DB::Result::SrcVer>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<suite>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<suite_idx_codename>
+
+=over 4
+
+=item * L</codename>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("suite_idx_codename", ["codename"]);
+
+=head2 C<suite_idx_version>
+
+=over 4
+
+=item * L</version>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("suite_idx_version", ["version"]);
+
+=head2 C<suite_suite_name_key>
+
+=over 4
+
+=item * L</suite_name>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("suite_suite_name_key", ["suite_name"]);
+
+=head1 RELATIONS
+
+=head2 bin_associations
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BinAssociation>
+
+=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<Debbugs::DB::Result::BugStatusCache>
+
+=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<Debbugs::DB::Result::SrcAssociation>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<tag>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<tag_tag_key>
+
+=over 4
+
+=item * L</tag>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("tag_tag_key", ["tag"]);
+
+=head1 RELATIONS
+
+=head2 bug_tags
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BugTag>
+
+=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;
--- /dev/null
+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<DBIx::Class::InflateColumn::DateTime>
+
+=item * L<DBIx::Class::TimeStamp>
+
+=back
+
+=cut
+
+__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp");
+
+=head1 TABLE: C<user_tag>
+
+=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</id>
+
+=back
+
+=cut
+
+__PACKAGE__->set_primary_key("id");
+
+=head1 UNIQUE CONSTRAINTS
+
+=head2 C<user_tag_tag_correspondent>
+
+=over 4
+
+=item * L</tag>
+
+=item * L</correspondent>
+
+=back
+
+=cut
+
+__PACKAGE__->add_unique_constraint("user_tag_tag_correspondent", ["tag", "correspondent"]);
+
+=head1 RELATIONS
+
+=head2 bug_user_tags
+
+Type: has_many
+
+Related object: L<Debbugs::DB::Result::BugUserTag>
+
+=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<Debbugs::DB::Result::Correspondent>
+
+=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;
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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<Debbugs::DB::Load::load_bug> 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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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 =~ /</) {
+ $addr = getparsedaddrs($addr);
+ $full_name = $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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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 <baz@example.com>')
+
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+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__
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
+
+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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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__
+
+
+
+
+
+
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+package Debbugs::Libravatar;
+
+=head1 NAME
+
+Debbugs::Libravatar -- Libravatar service handler (mod_perl)
+
+=head1 SYNOPSIS
+
+<Location /libravatar>
+ SetHandler perl-script
+ PerlResponseHandler Debbugs::Libravatar
+</Location>
+
+=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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2004 by Collin Watson <cjwatson@debian.org>
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>
+
+
+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<type> field is C<incoming-recv>, C<autocheck>,
+C<recips>, or C<html> as above; C<text> contains text from C<[mail]> or
+C<[html]> as above; C<recips> 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:
--- /dev/null
+# This module is part of debbugs, and is released under the terms of the GPL
+# version 2, or any later version (at your option). See the file README and
+# COPYING for more information.
+#
+# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
+
+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
+
+C<next if ($spam_log->is_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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2006 by Don Armstrong <don@donarmstrong.com>.
+
+
+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?= <don@donarmstrong.com>')
+
+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 <don@donarmstrong.com>')
+
+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;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2004-7 by Don Armstrong <don@donarmstrong.com>.
+
+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 => <<END, recipients=>[@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'} = "<handler.${bug_num}.${nn}.$param{msgtype}\@$config{email_domain}>";
+ 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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::OOBase;
+
+=head1 NAME
+
+Debbugs::OOBase -- OO Base class for Debbugs
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use Mouse;
+use strictures 2;
+use namespace::autoclean;
+
+has schema => (is => 'ro', isa => 'Object',
+ required => 0,
+ predicate => 'has_schema',
+ );
+
+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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::OOTypes;
+
+=head1 NAME
+
+Debbugs::OOTypes -- OO Types for Debbugs
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use Mouse::Util::TypeConstraints;
+use strictures 2;
+use namespace::autoclean;
+
+# Bug Subtype
+subtype 'Bug' =>
+ as 'Debbugs::Bug';
+
+coerce 'Bug' =>
+ from 'Int' =>
+ via {Debbugs::Bug->new($_)};
+
+# Package Subtype
+subtype 'Package' =>
+ as 'Debbugs::Package';
+
+coerce 'Package' =>
+ from 'Str' =>
+ via {Debbugs::Package->new(package => $_)};
+
+
+# Version Subtype
+subtype 'Version' =>
+ as 'Debbugs::Version';
+
+coerce 'Version' =>
+ from 'Str' =>
+ via {Debbugs::Version->new(string=>$_)};
+
+no Mouse::Util::TypeConstraints;
+1;
+
+__END__
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 3, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Package;
+
+=head1 NAME
+
+Debbugs::Package -- OO interface to packages
+
+=head1 SYNOPSIS
+
+ use Debbugs::Package;
+ Debbugs::Package->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
+
+=head1 DESCRIPTION
+
+
+
+=cut
+
+use 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<src:> 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<binary> or C<source>
+
+=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<Debbugs::Collection::Correspondent> 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<Debbugs::Collection::Package> 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<Debbugs::Collection::Correspondent> 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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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;
--- /dev/null
+# 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 <don@donarmstrong.com>.
+# $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<bcc>, C<cc>, or C<to>, 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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version at your option.
+# See the file README and COPYING for more information.
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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<Debbugs::Status::get_bug_status> 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<Debbugs::Status::get_bug_status> 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<Debbugs::Bugs::get_bugs> 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<Debbugs::Packages::binary_to_source> 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<Debbugs::Packages::sourcetobinary>)
+
+=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<Debbugs::Packages::get_versions>
+
+=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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later version at your option.
+# See the file README and COPYING for more information.
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2007-9 by Don Armstrong <don@donarmstrong.com>.
+
+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</getbugcomponent>
+
+=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<must> call
+C<unfilelock();> 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<bug> or C<summary> 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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+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(<option value=").html_escape($o_value).qq("$selected>).
+ html_escape($name).qq(</option>\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;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::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;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+# 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<URI> 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<URI> 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__
+
+
+
+
+
+
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
+
+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__
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people have contributed to this file; their copyrights should
+# go here too.]
+# Copyright 2004 by Anthony Towns
+# Copyright 2008 by Don Armstrong <don@donarmstrong.com>
+
+
+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__
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Version;
+
+=head1 NAME
+
+Debbugs::Version -- OO interface to Version
+
+=head1 SYNOPSIS
+
+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 C<Debbugs::Version::Binary->new(%params|$param)> for a binary version
+
+=over
+
+=item schema
+
+L<Debbugs::DB> schema which can be used to look up versions
+
+=item package
+
+String representation of the package
+
+=item pkg
+
+L<Debbugs::Package> which refers to the package given.
+
+Only one of C<package> or C<pkg> should be given
+
+=item package_collection
+
+L<Debbugs::Collection::Package> which is used to generate a L<Debbugs::Package>
+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<Debbugs::Package> object corresponding to C<package>.
+
+=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<Debugs::Collection::Package> 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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Version::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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::Version::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:
--- /dev/null
+# This module is part of debbugs, and
+# is released under the terms of the GPL version 2, or any later
+# version (at your option). See the file README and COPYING for more
+# information.
+# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::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:
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [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<sort>
+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<ancestor> and C<descendant>. Returns true if and only
+if C<ancestor> is a version on which C<descendant> 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<merge> 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<load>
+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<version>, C<found>, and C<fixed>. Returns true if
+and only if C<version> is based on or equal to a version in the list
+referenced by C<found>, and not based on or equal to one referenced by
+C<fixed>.
+
+C<buggy> 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<found> and C<fixed>, which are interpreted as in
+L</buggy>. 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</buggy>). If
+you pass a third argument, C<interested>, this method will stop after
+determining the state of the bug at all the versions listed therein.
+
+Whether this is faster than calling L</buggy> 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;
--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright Colin Watson <cjwatson@debian.org>
+# Copyright Ian Jackson <iwj@debian.org>
+# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
+
+
+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 <don@donarmstrong.com> and Colin Watson
+E<lt>cjwatson@debian.orgE<gt>, based on the implementation in
+C<dpkg/lib/vercmp.c> by Ian Jackson and others.
+
+=cut
+
+1;
--- /dev/null
+# 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;
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))
));
# 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>) {
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;
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;
};
$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';
projects / debbugs.git / commitdiff