From: Don Armstrong
Date: Wed, 24 Jul 2019 03:15:15 +0000 (-0700)
Subject: move Debbugs to lib
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=refs%2Fheads%2Fdon%2Fmove_lib;hp=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git
move Debbugs to lib
- We will eventually want to add more modules potentially outside of Debbugs
---
diff --git a/Debbugs/Bug.pm b/Debbugs/Bug.pm
deleted file mode 100644
index 21a26e3..0000000
--- a/Debbugs/Bug.pm
+++ /dev/null
@@ -1,678 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Bug;
-
-=head1 NAME
-
-Debbugs::Bug -- OO interface to bugs
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug;
- Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-
-use DateTime;
-use List::AllUtils qw(max first min any);
-
-use Params::Validate qw(validate_with :types);
-use Debbugs::Config qw(:config);
-use Debbugs::Status qw(read_bug);
-use Debbugs::Bug::Tag;
-use Debbugs::Bug::Status;
-use Debbugs::Collection::Package;
-use Debbugs::Collection::Bug;
-use Debbugs::Collection::Correspondent;
-
-use Debbugs::OOTypes;
-
-use Carp;
-
-extends 'Debbugs::OOBase';
-
-my $meta = __PACKAGE__->meta;
-
-state $strong_severities =
- {map {($_,1)} @{$config{strong_severities}}};
-
-has bug => (is => 'ro', isa => 'Int',
- required => 1,
- );
-
-sub id {
- return $_[0]->bug;
-}
-
-has saved => (is => 'ro', isa => 'Bool',
- default => 0,
- writer => '_set_saved',
- );
-
-has status => (is => 'ro', isa => 'Debbugs::Bug::Status',
- lazy => 1,
- builder => '_build_status',
- handles => {date => 'date',
- subject => 'subject',
- message_id => 'message_id',
- severity => 'severity',
- archived => 'archived',
- summary => 'summary',
- outlook => 'outlook',
- forwarded => 'forwarded',
- },
- );
-
-sub _build_status {
- my $self = shift;
- return Debbugs::Bug::Status->new(bug=>$self->bug,
- $self->schema_argument,
- );
-}
-
-has log => (is => 'bare', isa => 'Debbugs::Log',
- lazy => 1,
- builder => '_build_log',
- handles => {_read_record => 'read_record',
- log_records => 'read_all_records',
- },
- );
-
-sub _build_log {
- my $self = shift;
- return Debbugs::Log->new(bug_num => $self->id,
- inner_file => 1,
- );
-}
-
-has spam => (is => 'bare', isa => 'Debbugs::Log::Spam',
- lazy => 1,
- builder => '_build_spam',
- handles => ['is_spam'],
- );
-sub _build_spam {
- my $self = shift;
- return Debbugs::Log::Spam->new(bug_num => $self->id);
-}
-
-has 'package_collection' => (is => 'ro',
- isa => 'Debbugs::Collection::Package',
- builder => '_build_package_collection',
- lazy => 1,
- );
-
-sub _build_package_collection {
- my $self = shift;
- if ($self->has_schema) {
- return Debbugs::Collection::Package->new(schema => $self->schema);
- }
- carp "No schema when building package collection";
- return Debbugs::Collection::Package->new();
-}
-
-has bug_collection => (is => 'ro',
- isa => 'Debbugs::Collection::Bug',
- builder => '_build_bug_collection',
- );
-sub _build_bug_collection {
- my $self = shift;
- if ($self->has_schema) {
- return Debbugs::Collection::Bug->new(schema => $self->schema);
- }
- return Debbugs::Collection::Bug->new();
-}
-
-has correspondent_collection =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Correspondent',
- builder => '_build_correspondent_collection',
- lazy => 1,
- );
-sub _build_correspondent_collection {
- my $self = shift;
- return Debbugs::Collection::Correspondent->new($self->schema_argument);
-}
-
-# package attributes
-for my $attr (qw(packages affects sources)) {
- has $attr =>
- (is => 'rw',
- isa => 'Debbugs::Collection::Package',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- lazy => 1,
- );
-}
-
-# bugs
-for my $attr (qw(blocks blocked_by mergedwith)) {
- has $attr =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Bug',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- handles => {},
- lazy => 1,
- );
-}
-
-
-for my $attr (qw(owner submitter done)) {
- has $attr,
- (is => 'ro',
- isa => 'Maybe[Debbugs::Correspondent]',
- lazy => 1,
- builder => '_build_'.$attr.'_corr',
- clearer => '_clear_'.$attr.'_corr',
- handles => {$attr.'_url' => $attr.'_url',
- $attr.'_email' => 'email',
- $attr.'_phrase' => 'phrase',
- },
- );
- $meta->add_method('has_'.$attr,
- sub {my $self = shift;
- my $m = $meta->find_method_by_name($attr);
- return defined $m->($self);
- });
- $meta->add_method('_build_'.$attr.'_corr',
- sub {my $self = shift;
- my $m = $self->status->meta->find_method_by_name($attr);
- my $v = $m->($self->status);
- if (defined $v and length($v)) {
- return $self->correspondent_collection->
- get_or_add_by_key($v);
- } else {
- return undef;
- }
- }
- );
-}
-
-sub is_done {
- my $self = shift;
- return $self->has_done;
-}
-
-sub strong_severity {
- my $self = shift;
- return exists $strong_severities->{$self->severity};
-}
-
-sub short_severity {
- $_[0]->severity =~ m/^(.)/;
- return $1;
-}
-
-sub _build_packages {
- my $self = shift;
- return $self->package_collection->
- limit($self->status->package);
-}
-
-sub is_affecting {
- my $self = shift;
- return $self->affects->count > 0;
-}
-
-sub _build_affects {
- my $self = shift;
- return $self->package_collection->
- limit($self->status->affects);
-}
-sub _build_sources {
- my $self = shift;
- return $self->packages->sources->clone;
-}
-
-sub is_owned {
- my $self = shift;
- return defined $self->owner;
-}
-
-sub is_blocking {
- my $self = shift;
- return $self->blocks->count > 0;
-}
-
-sub _build_blocks {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->blocks);
-}
-
-sub is_blocked {
- my $self = shift;
- return $self->blocked_by->count > 0;
-}
-
-sub _build_blocked_by {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->blocked_by);
-}
-
-sub is_forwarded {
- length($_[0]->forwarded) > 0;
-}
-
-for my $attr (qw(fixed found)) {
- has $attr =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Version',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- handles => {},
- lazy => 1,
- );
-}
-
-sub has_found {
- my $self = shift;
- return any {1} $self->status->found;
-}
-
-sub _build_found {
- my $self = shift;
- return $self->packages->
- get_source_versions($self->status->found);
-}
-
-sub has_fixed {
- my $self = shift;
- return any {1} $self->status->fixed;
-}
-
-sub _build_fixed {
- my $self = shift;
- return $self->packages->
- get_source_versions($self->status->fixed);
-}
-
-sub is_merged {
- my $self = shift;
- return any {1} $self->status->mergedwith;
-}
-
-sub _build_mergedwith {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->mergedwith);
-}
-
-for my $attr (qw(created modified)) {
- has $attr => (is => 'rw', isa => 'Object',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- lazy => 1);
-}
-sub _build_created {
- return DateTime->
- from_epoch(epoch => $_[0]->status->date);
-}
-sub _build_modified {
- return DateTime->
- from_epoch(epoch => max($_[0]->status->log_modified,
- $_[0]->status->last_modified
- ));
-}
-
-has tags => (is => 'ro',
- isa => 'Debbugs::Bug::Tag',
- clearer => '_clear_tags',
- builder => '_build_tags',
- lazy => 1,
- );
-sub _build_tags {
- my $self = shift;
- return Debbugs::Bug::Tag->new(keywords => join(' ',$self->status->tags),
- bug => $self,
- users => $self->bug_collection->users,
- );
-}
-
-has pending => (is => 'ro',
- isa => 'Str',
- clearer => '_clear_pending',
- builder => '_build_pending',
- lazy => 1,
- );
-
-sub _build_pending {
- my $self = shift;
-
- my $pending = 'pending';
- if (length($self->status->forwarded)) {
- $pending = 'forwarded';
- }
- if ($self->tags->tag_is_set('pending')) {
- $pending = 'pending-fixed';
- }
- if ($self->tags->tag_is_set('pending')) {
- $pending = 'fixed';
- }
- # XXX This isn't quite right
- return $pending;
-}
-
-=head2 buggy
-
- $bug->buggy('debbugs/2.6.0-1','debbugs/2.6.0-2');
- $bug->buggy(Debbugs::Version->new('debbugs/2.6.0-1'),
- Debbugs::Version->new('debbugs/2.6.0-2'),
- );
-
-Returns the output of Debbugs::Versions::buggy for a particular
-package, version and found/fixed set. Automatically turns found, fixed
-and version into source/version strings.
-
-=cut
-
-sub buggy {
- my $self = shift;
- my $vertree =
- $self->package_collection->
- universe->versiontree;
- my $max_buggy = 'absent';
- for my $ver (@_) {
- if (not ref($ver)) {
- my @ver_opts = (version => $ver,
- package => $self->status->package,
- package_collection => $self->package_collection,
- $self->schema_arg
- );
- if ($ver =~ m{/}) {
- $ver = Debbugs::Version::Source->(@ver_opts);
- } else {
- $ver = Debbugs::Version::Binary->(@ver_opts);
- }
- }
- $vertree->load($ver->source);
- my $buggy =
- $vertree->buggy($ver,
- [$self->found],
- [$self->fixed]);
- if ($buggy eq 'found') {
- return 'found'
- }
- if ($buggy eq 'fixed') {
- $max_buggy = 'fixed';
- }
- }
- return $max_buggy;
-}
-
-has archiveable =>
- (is => 'ro', isa => 'Bool',
- writer => '_set_archiveable',
- builder => '_build_archiveable',
- clearer => '_clear_archiveable',
- lazy => 1,
- );
-has when_archiveable =>
- (is => 'ro', isa => 'Num',
- writer => '_set_when_archiveable',
- builder => '_build_when_archiveable',
- clearer => '_clear_when_archiveable',
- lazy => 1,
- );
-
-sub _build_archiveable {
- my $self = shift;
- $self->_populate_archiveable(0);
- return $self->archiveable;
-}
-sub _build_when_archiveable {
- my $self = shift;
- $self->_populate_archiveable(1);
- return $self->when_archiveable;
-}
-
-sub _populate_archiveable {
- my $self = shift;
- my ($need_time) = @_;
- $need_time //= 0;
- # Bugs can be archived if they are
- # 1. Closed
- if (not $self->done) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- # 2. Have no unremovable tags set
- if (@{$config{removal_unremovable_tags}}) {
- state $unrem_tags =
- {map {($_=>1)} @{$config{removal_unremovable_tags}}};
- for my $tag ($self->tags) {
- if ($unrem_tags->{$tag}) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- }
- }
- my $time = time;
- state $remove_time = 24 * 60 * 60 * ($config{removal_age} // 30);
- # 4. Have been modified more than removal_age ago
- my $moded_ago =
- $time - $self->modified->epoch;
- # if we don't need to know when we can archive, we can stop here if it's
- # been modified too recently
- if ($moded_ago < $remove_time) {
- $self->_set_archiveable(0);
- return unless $need_time;
- }
- my @distributions =
- @{$config{removal_default_distribution_tags}};
- if ($self->strong_severity) {
- @distributions =
- @{$config{removal_strong_severity_default_distribution_tags}};
- }
- # 3. Have a maximum buggy of fixed
- my $buggy = $self->buggy($self->packages->
- get_source_versions_distributions(@distributions));
- if ('found' eq $buggy) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- my $fixed_ago = $moded_ago;
- # $fixed_ago = $time - $self->when_fixed(@distributions);
- # if ($fixed_ago < $remove_time) {
- # $self->_set_archiveable(0);
- # }
- $self->_set_when_archiveable(($remove_time - min($fixed_ago,$moded_ago)) / (24 * 60 * 60));
- if ($fixed_ago > $remove_time and
- $moded_ago > $remove_time) {
- $self->_set_archiveable(1);
- $self->_set_when_archiveable(0);
- }
- return;
-}
-
-sub filter {
- my $self = shift;
- my %param = validate_with(params => \@_,
- spec => {seen_merged => {type => HASHREF,
- default => sub {return {}},
- },
- repeat_merged => {type => BOOLEAN,
- default => 1,
- },
- include => {type => HASHREF,
- optional => 1,
- },
- exclude => {type => HASHREF,
- optional => 1,
- },
- min_days => {type => SCALAR,
- optional => 1,
- },
- max_days => {type => SCALAR,
- optional => 1,
- },
- },
- );
- if (exists $param{include}) {
- return 1 if not $self->matches($param{include});
- }
- if (exists $param{exclude}) {
- return 1 if $self->matches($param{exclude});
- }
- if (exists $param{repeat_merged} and not $param{repeat_merged}) {
- my @merged = sort {$a<=>$b} $self->bug, $self->status->mergedwith;
- return 1 if first {sub {defined $_}}
- @{$param{seen_merged}}{@merged};
- @{$param{seen_merged}}{@merged} = (1) x @merged;
- }
- if (exists $param{min_days}) {
- return 1 unless $param{min_days} <=
- (DateTime->now() - $self->created)->days();
- }
- if (exists $param{max_days}) {
- return 1 unless $param{max_days} >=
- (DateTime->now() - $self->created)->days();
- }
- return 0;
-
-}
-
-sub __exact_match {
- my ($field, $values) = @_;
- my @ret = first {sub {$_ eq $field}} @{$values};
- return @ret != 0;
-}
-
-sub __contains_match {
- my ($field, $values) = @_;
- foreach my $value (@{$values}) {
- return 1 if (index($field, $value) > -1);
- }
- return 0;
-}
-
-state $field_match =
- {subject => sub {__contains_match($_[0]->subject,@_)},
- tags => sub {
- for my $value (@{$_[1]}) {
- if ($_[0]->tags->is_set($value)) {
- return 1;
- }
- }
- return 0;
- },
- severity => sub {__exact_match($_[0]->severity,@_)},
- pending => sub {__exact_match($_[0]->pending,@_)},
- originator => sub {__exact_match($_[0]->submitter,@_)},
- submitter => sub {__exact_match($_[0]->submitter,@_)},
- forwarded => sub {__exact_match($_[0]->forwarded,@_)},
- owner => sub {__exact_match($_[0]->owner,@_)},
- };
-
-sub matches {
- my ($self,$hash) = @_;
- for my $key (keys %{$hash}) {
- my $sub = $field_match->{$key};
- if (not defined $sub) {
- carp "No subroutine for key: $key";
- next;
- }
- return 1 if $sub->($self,$hash->{$key});
- }
- return 0;
-}
-
-sub email {
- my $self = shift;
- return $self->id.'@'.$config{email_domain};
-}
-
-sub subscribe_email {
- my $self = shift;
- return $self->id.'-subscribe@'.$config{email_domain};
-}
-
-sub url {
- my $self = shift;
- return $config{web_domain}.'/'.$self->id;
-}
-
-sub mbox_url {
- my $self = shift;
- return $config{web_domain}.'/mbox:'.$self->id;
-}
-
-sub mbox_status_url {
- my $self = shift;
- return $self->mbox_url.'?mboxstatus=yes';
-}
-
-sub mbox_maint_url {
- my $self = shift;
- $self->mbox_url.'?mboxmaint=yes';
-}
-
-sub version_url {
- my $self = shift;
- my $url = Debbugs::URI->new('version.cgi?');
- $url->query_form(package => $self->status->package(),
- found => [$self->status->found],
- fixed => [$self->status->fixed],
- @_,
- );
- return $url->as_string;
-}
-
-sub related_packages_and_versions {
- my $self = shift;
- my @packages = $self->status->package;
- my @versions = ($self->status->found,
- $self->status->fixed);
- my @unqualified_versions;
- my @return;
- for my $ver (@versions) {
- if ($ver =~ m{(.+)/(.+)}) { # It's a src_pkg_ver
- push @return, ['src:'.$+{src}, $+{ver}];
- } else {
- push @unqualified_versions,$ver;
- }
- }
- for my $pkg (@packages) {
- if (@unqualified_versions) {
- push @return,
- [$pkg,@unqualified_versions];
- } else {
- push @return,$pkg;
- }
- }
- return @return;
-}
-
-sub CARP_TRACE {
- my $self = shift;
- return 'Debbugs::Bug={bug='.$self->bug.'}';
-}
-
-__PACKAGE__->meta->make_immutable;
-
-no Mouse;
-1;
-
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Bug/Status.pm b/Debbugs/Bug/Status.pm
deleted file mode 100644
index 9209485..0000000
--- a/Debbugs/Bug/Status.pm
+++ /dev/null
@@ -1,576 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Bug::Status;
-
-=head1 NAME
-
-Debbugs::Bug::Status -- OO interface to status files
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug;
- Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-use Mouse::Util::TypeConstraints qw(enum);
-
-use DateTime;
-use List::AllUtils qw(max first min);
-
-use Params::Validate qw(validate_with :types);
-use Debbugs::Common qw(make_list);
-use Debbugs::Config qw(:config);
-use Debbugs::Status qw(get_bug_status);
-
-use Debbugs::OOTypes;
-
-use Carp;
-
-extends 'Debbugs::OOBase';
-
-my $meta = __PACKAGE__->meta;
-
-has bug => (is => 'ro', isa => 'Int',
- );
-
-# status obtained from DB, filesystem, or hashref
-has status_source => (is => 'ro',
- isa => enum([qw(db filesystem hashref)]),
- default => 'filesystem',
- writer => '_set_status_source',
- );
-
-has _status => (is => 'bare',
- writer => '_set_status',
- reader => '_status',
- predicate => '_has__status',
- );
-
-my %field_methods;
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- state $field_mapping =
- {originator => 'submitter',
- keywords => 'tags',
- msgid => 'message_id',
- blockedby => 'blocked_by',
- found_versions => 'found',
- fixed_versions => 'fixed',
- };
- if (not exists $args->{status} and exists $args->{bug}) {
- if ($self->has_schema) {
- ($args->{status}) =
- $self->schema->resultset('BugStatus')->
- search_rs({id => [make_list($args->{bug})]},
- {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})->
- all();
- for my $field (keys %{$field_mapping}) {
- $args->{status}{$field_mapping->{$field}} =
- $args->{status}{$field} if defined $args->{status}{$field};
- delete $args->{status}{$field};
- }
- $self->_set_status_source('db');
- } else {
- $args->{status} = get_bug_status(bug=>$args->{bug});
- for my $field (keys %{$field_mapping}) {
- $args->{status}{$field_mapping->{$field}} =
- $args->{status}{$field} if defined $args->{status}{$field};
- }
- $self->_set_status_source('filesystem');
- }
- } elsif (exists $args->{status}) {
- for my $field (keys %{$field_mapping}) {
- $args->{status}{$field_mapping->{$field}} =
- $args->{status}{$field} if defined $args->{status}{$field};
- }
- $self->_set_status_source('hashref');
- }
- if (exists $args->{status}) {
- if (ref($args->{status}) ne 'HASH') {
- croak "status must be a HASHREF (argument to __PACKAGE__)";
- }
- $self->_set_status($args->{status});
- delete $args->{status};
- }
-}
-
-has saved => (is => 'ro', isa => 'Bool',
- default => 0,
- writer => '_set_set_saved',
- );
-
-sub __field_or_def {
- my ($self,$field,$default) = @_;
- if ($self->_has__status) {
- my $s = $self->_status()->{$field};
- return $s if defined $s;
- }
- return $default;
-}
-
-=head2 Status Fields
-
-=cut
-
-=head3 Single-value Fields
-
-=over
-
-=item submitter (single)
-
-=cut
-
-has submitter =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('submitter',
- $config{maintainer_email});
- },
- lazy => 1,
- writer => '_set_submitter',
- );
-
-=item date (single)
-
-=cut
-
-has date =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('date',
- time);
- },
- lazy => 1,
- writer => '_set_date',
- );
-
-=item last_modified (single)
-
-=cut
-
-has last_modified =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('last_modified',
- time);
- },
- lazy => 1,
- writer => '_set_last_modified',
- );
-
-=item log_modified (single)
-
-=cut
-
-has log_modified =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('log_modified',
- time);
- },
- lazy => 1,
- writer => '_set_log_modified',
- );
-
-
-=item subject
-
-=cut
-
-has subject =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('subject',
- 'No subject');
- },
- lazy => 1,
- writer => '_set_subject',
- );
-
-=item message_id
-
-=cut
-
-has message_id =>
- (is => 'ro',
- isa => 'Str',
- lazy => 1,
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('message_id',
- 'nomessageid.'.$self->date.'_'.
- md5_hex($self->subject.$self->submitter).
- '@'.$config{email_domain},
- );
- },
- writer => '_set_message_id',
- );
-
-
-=item done
-
-=item severity
-
-=cut
-
-has severity =>
- (is => 'ro',
- isa => 'Str',
- lazy => 1,
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('severity',
- $config{default_severity});
- },
- writer => '_set_severity',
- );
-
-=item unarchived
-
-Unix epoch the bug was last unarchived. Zero if the bug has never been
-unarchived.
-
-=cut
-
-has unarchived =>
- (is => 'ro',
- isa => 'Int',
- lazy => 1,
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('unarchived',
- 0);
- },
- writer => '_set_unarchived',
- );
-
-=item archived
-
-True if the bug is archived, false otherwise.
-
-=cut
-
-has archived =>
- (is => 'ro',
- isa => 'Int',
- lazy => 1,
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def('archived',
- 0);
- },
- writer => '_set_archived',
- );
-
-=item owner
-
-=item summary
-
-=item outlook
-
-=item done
-
-=item forwarded
-
-=cut
-
-for my $field (qw(owner unarchived summary outlook done forwarded)) {
- has $field =>
- (is => 'ro',
- isa => 'Str',
- builder =>
- sub {
- my $self = shift;
- $self->__field_or_def($field,
- '');
- },
- writer => '_set_'.$field,
- lazy => 1,
- );
- my $field_method = $meta->find_method_by_name($field);
- die "No field method for $field" unless defined $field_method;
- $meta->add_method('has_'.$field =>
- sub {my $self = shift;
- return length($field_method->($self));
- });
-}
-
-=back
-
-=head3 Multi-value Fields
-
-=over
-
-=item affects
-
-=item package
-
-=item tags
-
-=cut
-
-for my $field (qw(affects package tags)) {
- has '_'.$field =>
- (is => 'ro',
- traits => [qw(Array)],
- isa => 'ArrayRef[Str]',
- builder =>
- sub {
- my $self = shift;
- if ($self->_has__status) {
- my $s = $self->_status()->{$field};
- if (!ref($s)) {
- $s = _build_split_field($s,
- $field);
- }
- return $s;
- }
- return [];
- },
- writer => '_set_'.$field,
- handles => {$field => 'elements',
- $field.'_count' => 'count',
- $field.'_join' => 'join',
- },
- lazy => 1,
- );
- my $field_method = $meta->find_method_by_name($field);
- if (defined $field_method) {
- $meta->add_method($field.'_ref'=>
- sub {my $self = shift;
- return [$field_method->($self)]
- });
- }
-}
-
-=item found
-
-=item fixed
-
-=cut
-
-sub __hashref_field {
- my ($self,$field) = @_;
-
- if ($self->_has__status) {
- my $s = $self->_status()->{$field};
- if (!ref($s)) {
- $s = _build_split_field($s,
- $field);
- }
- return $s;
- }
- return [];
-}
-
-for my $field (qw(found fixed)) {
- has '_'.$field =>
- (is => 'ro',
- traits => ['Hash'],
- isa => 'HashRef[Str]',
- builder =>
- sub {
- my $self = shift;
- if ($self->_has__status) {
- my $s = $self->_status()->{$field};
- if (!ref($s)) {
- $s = _build_split_field($s,
- $field);
- }
- if (ref($s) ne 'HASH') {
- $s = {map {$_,'1'} @{$s}};
- }
- return $s;
- }
- return {};
- },
- default => sub {return {}},
- writer => '_set_'.$field,
- handles => {$field => 'keys',
- $field.'_count' => 'count',
- },
- lazy => 1,
- );
- my $field_method = $meta->find_method_by_name($field);
- if (defined $field_method) {
- $meta->add_method('_'.$field.'_ref'=>
- sub {my $self = shift;
- return [$field_method->($self)]
- });
- $meta->add_method($field.'_join'=>
- sub {my ($self,$joiner) = @_;
- return join($joiner,$field_method->($self));
- });
- }
-}
-
-
-for (qw(found fixed)) {
- around '_set_'.$_ => sub {
- my $orig = shift;
- my $self = shift;
- if (defined ref($_[0]) and
- ref($_[0]) eq 'ARRAY'
- ) {
- @_ = {map {$_,'1'} @{$_[0]}};
- } elsif (@_ > 1) {
- @_ = {map {$_,'1'} @_};
- }
- $self->$orig(@_);
- };
-}
-
-
-
-=item mergedwith
-
-=item blocks
-
-=item blocked_by
-
-=cut
-
-for my $field (qw(blocks blocked_by mergedwith)) {
- has '_'.$field =>
- (is => 'ro',
- traits => ['Hash'],
- isa => 'HashRef[Int]',
- builder =>
- sub {
- my $self = shift;
- if ($self->_has__status) {
- my $s = $self->_status()->{$field};
- if (!ref($s)) {
- $s = _build_split_field($s,
- $field);
- }
- if (ref($s) ne 'HASH') {
- $s = {map {$_,'1'} @{$s}};
- }
- return $s;
- }
- return {};
- },
- handles => {$field.'_count' => 'count',
- },
- writer => '_set_'.$field,
- lazy => 1,
- );
- my $internal_field_method = $meta->find_method_by_name('_'.$field);
- die "No field method for _$field" unless defined $internal_field_method;
- $meta->add_method($field =>
- sub {my $self = shift;
- return sort {$a <=> $b}
- keys %{$internal_field_method->($self)};
- });
- my $field_method = $meta->find_method_by_name($field);
- die "No field method for _$field" unless defined $field_method;
- $meta->add_method('_'.$field.'_ref'=>
- sub {my $self = shift;
- return [$field_method->($self)]
- });
- $meta->add_method($field.'_join'=>
- sub {my ($self,$joiner) = @_;
- return join($joiner,$field_method->($self));
- });
-}
-
-for (qw(blocks blocked_by mergedwith)) {
- around '_set_'.$_ => sub {
- my $orig = shift;
- my $self = shift;
- if (defined ref($_[0]) and
- ref($_[0]) eq 'ARRAY'
- ) {
- $_[0] = {map {$_,'1'} @{$_[0]}};
- } elsif (@_ > 1) {
- @_ = {map {$_,'1'} @{$_[0]}};
- }
- $self->$orig(@_);
- };
-}
-
-=back
-
-=cut
-
-sub _build_split_field {
- sub sort_and_unique {
- my @v;
- my %u;
- my $all_numeric = 1;
- for my $v (@_) {
- if ($all_numeric and $v =~ /\D/) {
- $all_numeric = 0;
- }
- next if exists $u{$v};
- $u{$v} = 1;
- push @v, $v;
- }
- if ($all_numeric) {
- return sort {$a <=> $b} @v;
- } else {
- return sort @v;
- }
- }
- sub split_ditch_empty {
- return grep {length $_} map {split ' '} @_;
-
- }
- my ($val,$field) = @_;
- $val //= '';
-
- if ($field =~ /^(package|affects|source)$/) {
- return [grep {length $_} map lc, split /[\s,()?]+/, $val];
- } else {
- return [sort_and_unique(split_ditch_empty($val))];
- }
-}
-
-
-__PACKAGE__->meta->make_immutable;
-
-no Mouse;
-no Mouse::Util::TypeConstraints;
-1;
-
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Bug/Tag.pm b/Debbugs/Bug/Tag.pm
deleted file mode 100644
index 06dfb3f..0000000
--- a/Debbugs/Bug/Tag.pm
+++ /dev/null
@@ -1,212 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Bug::Tag;
-
-=head1 NAME
-
-Debbugs::Bug::Tag -- OO interface to bug tags
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug::Tag;
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-
-use Debbugs::User;
-use List::AllUtils qw(uniq);
-use Debbugs::Config qw(:config);
-use Carp qw(croak);
-
-state $valid_tags =
- {map {($_,1)} @{$config{tags}}};
-
-state $short_tags =
- {%{$config{tags_single_letter}}};
-
-extends 'Debbugs::OOBase';
-
-around BUILDARGS => sub {
- my $orig = shift;
- my $class = shift;
- if (@_ == 1 && !ref $_[0]) {
- return $class->$orig(keywords => $_[0]);
- } else {
- return $class->$orig(@_);
- }
-};
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- if (exists $args->{keywords}) {
- my @tags;
- if (ref($args->{keywords})) {
- @tags = @{$args->{keywords}}
- } else {
- @tags = split /[, ]/,$args->{keywords};
- }
- return unless @tags;
- $self->_set_tag(map {($_,1)} @tags);
- delete $args->{keywords};
- }
-}
-
-has tags => (is => 'ro',
- isa => 'HashRef[Str]',
- traits => ['Hash'],
- lazy => 1,
- reader => '_tags',
- builder => '_build_tags',
- handles => {has_tags => 'count',
- _set_tag => 'set',
- unset_tag => 'delete',
- },
- );
-has usertags => (is => 'ro',
- isa => 'HashRef[Str]',
- lazy => 1,
- traits => ['Hash'],
- handles => {unset_usertag => 'delete',
- has_usertags => 'count',
- },
- reader => '_usertags',
- builder => '_build_usertags',
- );
-
-sub has_any_tags {
- my $self = shift;
- return ($self->has_tags || $self->has_usertags);
-}
-
-has bug => (is => 'ro',
- isa => 'Debbugs::Bug',
- required => 1,
- );
-
-has users => (is => 'ro',
- isa => 'ArrayRef[Debbugs::User]',
- default => sub {[]},
- );
-
-sub _build_tags {
- return {};
-}
-
-sub _build_usertags {
- my $self = shift;
- local $_;
- my $t = {};
- my $id = $self->bug->id;
- for my $user (@{$self->users}) {
- for my $tag ($user->tags_on_bug($id)) {
- $t->{$tag} = $user->email;
- }
- }
- return $t;
-}
-
-sub is_set {
- return ($_[0]->tag_is_set($_[1]) or
- $_[0]->usertag_is_set($_[1]));
-}
-
-sub tag_is_set {
- return exists $_[0]->_tags->{$_[1]} ? 1 : 0;
-}
-
-sub usertag_is_set {
- return exists $_[0]->_usertags->{$_[1]} ? 1 : 0;
-}
-
-sub set_tag {
- my $self = shift;
- for my $tag (@_) {
- if (not $self->valid_tag($tag)) {
- confess("Invalid tag $tag");
- }
- $self->_tags->{$tag} = 1;
- }
- return $self;
-}
-
-sub valid_tag {
- return exists $valid_tags->{$_[1]}?1:0;
-}
-
-sub as_string {
- my $self = shift;
- return $self->join_all(' ');
-}
-
-sub join_all {
- my $self = shift;
- my $joiner = shift;
- $joiner //= ', ';
- return join($joiner,$self->all_tags);
-}
-
-sub join_usertags {
- my $self = shift;
- my $joiner = shift;
- $joiner //= ', ';
- return join($joiner,$self->usertags);
-}
-
-sub join_tags {
- my $self = shift;
- my $joiner = shift;
- $joiner //= ', ';
- return join($joiner,$self->tags);
-}
-
-sub all_tags {
- return uniq sort $_[0]->tags,$_[0]->usertags;
-}
-
-sub tags {
- return sort keys %{$_[0]->_tags}
-}
-
-sub short_tags {
- my $self = shift;
- my @r;
- for my $tag ($self->tags) {
- next unless exists $short_tags->{$tag};
- push @r,
- {long => $tag,
- short => $short_tags->{$tag},
- };
- }
- if (wantarray) {
- return @r;
- } else {
- return [@r];
- }
-}
-
-sub usertags {
- return sort keys %{$_[0]->_usertags}
-}
-
-no Mouse;
-1;
-
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Bugs.pm b/Debbugs/Bugs.pm
deleted file mode 100644
index 127e472..0000000
--- a/Debbugs/Bugs.pm
+++ /dev/null
@@ -1,959 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong .
-
-package Debbugs::Bugs;
-
-=head1 NAME
-
-Debbugs::Bugs -- Bug selection routines for debbugs
-
-=head1 SYNOPSIS
-
-use Debbugs::Bugs qw(get_bugs);
-
-
-=head1 DESCRIPTION
-
-This module is a replacement for all of the various methods of
-selecting different types of bugs.
-
-It implements a single function, get_bugs, which defines the master
-interface for selecting bugs.
-
-It attempts to use subsidiary functions to actually do the selection,
-in the order specified in the configuration files. [Unless you're
-insane, they should be in order from fastest (and often most
-incomplete) to slowest (and most complete).]
-
-=head1 BUGS
-
-=head1 FUNCTIONS
-
-=cut
-
-use warnings;
-use strict;
-use feature 'state';
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-BEGIN{
- $VERSION = 1.00;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = ();
- @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter));
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-use Debbugs::Config qw(:config);
-use Params::Validate qw(validate_with :types);
-use IO::File;
-use Debbugs::Status qw(splitpackages get_bug_status);
-use Debbugs::Packages qw(getsrcpkgs getpkgsrc);
-use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice);
-use Fcntl qw(O_RDONLY);
-use MLDBM qw(DB_File Storable);
-use List::AllUtils qw(first max);
-use Carp;
-
-=head2 get_bugs
-
- get_bugs()
-
-=head3 Parameters
-
-The following parameters can either be a single scalar or a reference
-to an array. The parameters are ANDed together, and the elements of
-arrayrefs are a parameter are ORed. Future versions of this may allow
-for limited regular expressions, and/or more complex expressions.
-
-=over
-
-=item package -- name of the binary package
-
-=item src -- name of the source package
-
-=item maint -- address of the maintainer
-
-=item submitter -- address of the submitter
-
-=item severity -- severity of the bug
-
-=item status -- status of the bug
-
-=item tag -- bug tags
-
-=item owner -- owner of the bug
-
-=item correspondent -- address of someone who sent mail to the log
-
-=item affects -- bugs which affect this package
-
-=item dist -- distribution (I don't know about this one yet)
-
-=item bugs -- list of bugs to search within
-
-=item function -- see description below
-
-=back
-
-=head3 Special options
-
-The following options are special options used to modulate how the
-searches are performed.
-
-=over
-
-=item archive -- whether to search archived bugs or normal bugs;
-defaults to false. As a special case, if archive is 'both', but
-archived and unarchived bugs are returned.
-
-=item usertags -- set of usertags and the bugs they are applied to
-
-=back
-
-
-=head3 Subsidiary routines
-
-All subsidiary routines get passed exactly the same set of options as
-get_bugs. If for some reason they are unable to handle the options
-passed (for example, they don't have the right type of index for the
-type of selection) they should die as early as possible. [Using
-Params::Validate and/or die when files don't exist makes this fairly
-trivial.]
-
-This function will then immediately move on to the next subroutine,
-giving it the same arguments.
-
-=head3 function
-
-This option allows you to provide an arbitrary function which will be
-given the information in the index.db file. This will be super, super
-slow, so only do this if there's no other way to write the search.
-
-You'll be given a list (which you can turn into a hash) like the
-following:
-
- (pkg => ['a','b'], # may be a scalar (most common)
- bug => 1234,
- status => 'pending',
- submitter => 'boo@baz.com',
- severity => 'serious',
- tags => ['a','b','c'], # may be an empty arrayref
- )
-
-The function should return 1 if the bug should be included; 0 if the
-bug should not.
-
-=cut
-
-state $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/;
-
-my %_get_bugs_common_options =
- (package => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- src => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maint => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- submitter => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- severity => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- status => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- tag => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- owner => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- dist => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- correspondent => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- affects => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- function => {type => CODEREF,
- optional => 1,
- },
- bugs => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- archive => {type => BOOLEAN|SCALAR,
- default => 0,
- },
- usertags => {type => HASHREF,
- optional => 1,
- },
- newest => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- schema => {type => OBJECT,
- optional => 1,
- },
- );
-
-
-state $_get_bugs_options = {%_get_bugs_common_options};
-sub get_bugs{
- my %param = validate_with(params => \@_,
- spec => $_get_bugs_options,
- );
-
- # Normalize options
- my %options = %param;
- my @bugs;
- if ($options{archive} eq 'both') {
- push @bugs, get_bugs(%options,archive=>0);
- push @bugs, get_bugs(%options,archive=>1);
- my %bugs;
- @bugs{@bugs} = @bugs;
- return keys %bugs;
- }
- # A configuration option will set an array that we'll use here instead.
- for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
- my ($package) = $routine =~ m/^(.+)\:\:/;
- eval "use $package;";
- if ($@) {
- # We output errors here because using an invalid function
- # in the configuration file isn't something that should
- # be done.
- warn "use $package failed with $@";
- next;
- }
- @bugs = eval "${routine}(\%options)";
- if ($@) {
-
- # We don't output errors here, because failure here
- # via die may be a perfectly normal thing.
- print STDERR "$@" if $DEBUG;
- next;
- }
- last;
- }
- # If no one succeeded, die
- if ($@) {
- die "$@";
- }
- return @bugs;
-}
-
-=head2 count_bugs
-
- count_bugs(function => sub {...})
-
-Uses a subroutine to classify bugs into categories and return the
-number of bugs which fall into those categories
-
-=cut
-
-sub count_bugs {
- my %param = validate_with(params => \@_,
- spec => {function => {type => CODEREF,
- },
- archive => {type => BOOLEAN,
- default => 0,
- },
- },
- );
- my $flatfile;
- if ($param{archive}) {
- $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
- or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
- }
- else {
- $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
- or die "Unable to open $config{spool_dir}/index.db for reading: $!";
- }
- my %count = ();
- while(<$flatfile>) {
- if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
- my @x = $param{function}->(pkg => $1,
- bug => $2,
- status => $4,
- submitter => $5,
- severity => $6,
- tags => $7,
- );
- local $_;
- $count{$_}++ foreach @x;
- }
- }
- close $flatfile;
- return %count;
-}
-
-=head2 newest_bug
-
- my $bug = newest_bug();
-
-Returns the bug number of the newest bug, which is nextnumber-1.
-
-=cut
-
-sub newest_bug {
- my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
- or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
- local $/;
- my $next_number = <$nn_fh>;
- close $nn_fh;
- chomp $next_number;
- return $next_number-1;
-}
-
-=head2 bug_filter
-
- bug_filter
-
-Allows filtering bugs on commonly used criteria
-
-
-
-=cut
-
-sub bug_filter {
- my %param = validate_with(params => \@_,
- spec => {bug => {type => ARRAYREF|SCALAR,
- optional => 1,
- },
- status => {type => HASHREF|ARRAYREF,
- optional => 1,
- },
- seen_merged => {type => HASHREF,
- optional => 1,
- },
- repeat_merged => {type => BOOLEAN,
- default => 1,
- },
- include => {type => HASHREF,
- optional => 1,
- },
- exclude => {type => HASHREF,
- optional => 1,
- },
- min_days => {type => SCALAR,
- optional => 1,
- },
- max_days => {type => SCALAR,
- optional => 1,
- },
- },
- );
- if (exists $param{repeat_merged} and
- not $param{repeat_merged} and
- not defined $param{seen_merged}) {
- croak "repeat_merged false requires seen_merged to be passed";
- }
- if (not exists $param{bug} and not exists $param{status}) {
- croak "one of bug or status must be passed";
- }
-
- if (not exists $param{status}) {
- my $location = getbuglocation($param{bug}, 'summary');
- return 0 if not defined $location or not length $location;
- $param{status} = readbug( $param{bug}, $location );
- return 0 if not defined $param{status};
- }
-
- if (exists $param{include}) {
- return 1 if (!__bug_matches($param{include}, $param{status}));
- }
- if (exists $param{exclude}) {
- return 1 if (__bug_matches($param{exclude}, $param{status}));
- }
- if (exists $param{repeat_merged} and not $param{repeat_merged}) {
- my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
- return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
- @{$param{seen_merged}}{@merged} = (1) x @merged;
- }
- my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days
- if (exists $param{min_days}) {
- return 1 unless $param{min_days} <= $daysold;
- }
- if (exists $param{max_days}) {
- return 1 unless $param{max_days} == -1 or
- $param{max_days} >= $daysold;
- }
- return 0;
-}
-
-
-=head2 get_bugs_by_idx
-
-This routine uses the by-$index.idx indicies to try to speed up
-searches.
-
-
-=cut
-
-
-state $_get_bugs_by_idx_options =
- {hash_slice(%_get_bugs_common_options,
- (qw(package submitter severity tag archive),
- qw(owner src maint bugs correspondent),
- qw(affects usertags newest))
- )
- };
-sub get_bugs_by_idx{
- my %param = validate_with(params => \@_,
- spec => $_get_bugs_by_idx_options
- );
- my %bugs = ();
-
- # If we're given an empty maint (unmaintained packages), we can't
- # handle it, so bail out here
- for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
- if (defined $maint and $maint eq '') {
- die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
- }
- }
- if ($param{newest}) {
- my $newest_bug = newest_bug();
- my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug;
- $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(),
- @bugs,
- ];
- }
- # We handle src packages, maint and maintenc by mapping to the
- # appropriate binary packages, then removing all packages which
- # don't match all queries
- my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
- qw(package src maint)
- );
- if (exists $param{package} or
- exists $param{src} or
- exists $param{maint}) {
- delete @param{qw(maint src)};
- $param{package} = [@packages];
- }
- my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
- die "Need at least 1 key to search by" unless $keys;
- my $arc = $param{archive} ? '-arc':'';
- my %idx;
- for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
- my $index = $key;
- $index = 'submitter-email' if $key eq 'submitter';
- $index = "$config{spool_dir}/by-${index}${arc}.idx";
- tie(%idx, MLDBM => $index, O_RDONLY)
- or die "Unable to open $index: $!";
- my %bug_matching = ();
- for my $search (make_list($param{$key})) {
- for my $bug (keys %{$idx{$search}||{}}) {
- next if $bug_matching{$bug};
- # increment the number of searches that this bug matched
- $bugs{$bug}++;
- $bug_matching{$bug}=1;
- }
- if ($search ne lc($search)) {
- for my $bug (keys %{$idx{lc($search)}||{}}) {
- next if $bug_matching{$bug};
- # increment the number of searches that this bug matched
- $bugs{$bug}++;
- $bug_matching{$bug}=1;
- }
- }
- }
- if ($key eq 'tag' and exists $param{usertags}) {
- for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
- next if $bug_matching{$bug};
- $bugs{$bug}++;
- $bug_matching{$bug}=1;
- }
- }
- untie %idx or die 'Unable to untie %idx';
- }
- if ($param{bugs}) {
- $keys++;
- for my $bug (make_list($param{bugs})) {
- $bugs{$bug}++;
- }
- }
- # Throw out results that do not match all of the search specifications
- return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
-}
-
-
-=head2 get_bugs_by_db
-
-This routine uses the database to try to speed up
-searches.
-
-
-=cut
-
-state $_get_bugs_by_db_options =
- {hash_slice(%_get_bugs_common_options,
- (qw(package submitter severity tag archive),
- qw(owner src maint bugs correspondent),
- qw(affects usertags newest))
- ),
- schema => {type => OBJECT,
- },
- };
-sub get_bugs_by_db{
- my %param = validate_with(params => \@_,
- spec => $_get_bugs_by_db_options,
- );
- my %bugs = ();
-
- my $s = $param{schema};
- my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
- die "Need at least 1 key to search by" unless $keys;
- my $rs = $s->resultset('Bug');
- if (exists $param{severity}) {
- $rs = $rs->search({'severity.severity' =>
- [make_list($param{severity})],
- },
- {join => 'severity'},
- );
- }
- for my $key (qw(owner submitter done)) {
- if (exists $param{$key}) {
- $rs = $rs->search({"${key}.addr" =>
- [make_list($param{$key})],
- },
- {join => $key},
- );
- }
- }
- if (exists $param{newest}) {
- $rs =
- $rs->search({},
- {order_by => {-desc => 'me.creation'},
- rows => max(make_list($param{newest})),
- },
- );
- }
- if (exists $param{correspondent}) {
- my $message_rs =
- $s->resultset('Message')->
- search({'correspondent.addr' =>
- [make_list($param{correspondent})],
- },
- {join => {message_correspondents => 'correspondent'},
- columns => ['id'],
- group_by => ['me.id'],
- },
- );
- $rs = $rs->search({'bug_messages.message' =>
- {-in => $message_rs->get_column('id')->as_query()},
- },
- {join => 'bug_messages',
- },
- );
- }
- if (exists $param{affects}) {
- my @aff_list = make_list($param{affects});
- s/^src:// foreach @aff_list;
- $rs = $rs->search({-or => {'bin_pkg.pkg' =>
- [@aff_list],
- 'src_pkg.pkg' =>
- [@aff_list],
- 'me.unknown_affects' =>
- [@aff_list]
- },
- },
- {join => [{bug_affects_binpackages => 'bin_pkg'},
- {bug_affects_srcpackages => 'src_pkg'},
- ],
- },
- );
- }
- if (exists $param{package}) {
- $rs = $rs->search({-or => {'bin_pkg.pkg' =>
- [make_list($param{package})],
- 'me.unknown_packages' =>
- [make_list($param{package})]},
- },
- {join => {bug_binpackages => 'bin_pkg'}});
- }
- if (exists $param{maint}) {
- my @maint_list =
- map {$_ eq '' ? undef : $_}
- make_list($param{maint});
- my $bin_pkgs_rs =
- $s->resultset('BinPkg')->
- search({'correspondent.addr' => [@maint_list]},
- {join => {bin_vers =>
- {src_ver =>
- {maintainer => 'correspondent'}}},
- columns => ['id'],
- group_by => ['me.id'],
- },
- );
- my $src_pkgs_rs =
- $s->resultset('SrcPkg')->
- search({'correspondent.addr' => [@maint_list]},
- {join => {src_vers =>
- {maintainer => 'correspondent'}},
- columns => ['id'],
- group_by => ['me.id'],
- },
- );
- $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
- { -in => $bin_pkgs_rs->get_column('id')->as_query},
- 'bug_srcpackages.src_pkg' =>
- { -in => $src_pkgs_rs->get_column('id')->as_query},
- },
- },
- {join => ['bug_binpackages',
- 'bug_srcpackages',
- ]}
- );
- }
- if (exists $param{src}) {
- # identify all of the srcpackages and binpackages that match first
- my $src_pkgs_rs =
- $s->resultset('SrcPkg')->
- search({'pkg' => [make_list($param{src})],
- },
- { columns => ['id'],
- group_by => ['me.id'],
- },
- );
- my $bin_pkgs_rs =
- $s->resultset('BinPkgSrcPkg')->
- search({'src_pkg.pkg' => [make_list($param{src})],
- },
- {columns => ['bin_pkg'],
- join => ['src_pkg'],
- group_by => ['bin_pkg'],
- });
- $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
- { -in => $bin_pkgs_rs->get_column('bin_pkg')->as_query},
- 'bug_srcpackages.src_pkg' =>
- { -in => $src_pkgs_rs->get_column('id')->as_query},
- 'me.unknown_packages' =>
- [make_list($param{src})],
- },
- },
- {join => ['bug_binpackages',
- 'bug_srcpackages',
- ]}
- );
- }
- # tags are very odd, because we must handle usertags.
- if (exists $param{tag}) {
- # bugs from usertags which matter
- my %bugs_matching_usertags;
- for my $bug (make_list(grep {defined $_ }
- @{$param{usertags}}{make_list($param{tag})})) {
- $bugs_matching_usertags{$bug} = 1;
- }
- # we want all bugs which either match the tag name given in
- # param, or have a usertag set which matches one of the tag
- # names given in param.
- $rs = $rs->search({-or => {map {('tag.tag' => $_)}
- make_list($param{tag}),
- map {('me.id' => $_)}
- keys %bugs_matching_usertags
- },
- },
- {join => {bug_tags => 'tag'}});
- }
- if (exists $param{bugs}) {
- $rs = $rs->search({-or => {map {('me.id' => $_)}
- make_list($param{bugs})}
- });
- }
- # handle archive
- if (defined $param{archive} and $param{archive} ne 'both') {
- $rs = $rs->search({'me.archived' => $param{archive}});
- }
- return $rs->get_column('id')->all();
-}
-
-
-=head2 get_bugs_flatfile
-
-This is the fallback search routine. It should be able to complete all
-searches. [Or at least, that's the idea.]
-
-=cut
-
-state $_get_bugs_flatfile_options =
- {hash_slice(%_get_bugs_common_options,
- map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
- )
- };
-
-sub get_bugs_flatfile{
- my %param = validate_with(params => \@_,
- spec => $_get_bugs_flatfile_options
- );
- my $flatfile;
- if ($param{newest}) {
- my $newest_bug = newest_bug();
- my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug;
- $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(),
- @bugs,
- ];
- }
- if ($param{archive}) {
- $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
- or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
- }
- else {
- $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
- or die "Unable to open $config{spool_dir}/index.db for reading: $!";
- }
- my %usertag_bugs;
- if (exists $param{tag} and exists $param{usertags}) {
- # This complex slice makes a hash with the bugs which have the
- # usertags passed in $param{tag} set.
- @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
- } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
- }
- my $unmaintained_packages = 0;
- # unmaintained packages is a special case
- my @maints = make_list(exists $param{maint}?$param{maint}:[]);
- $param{maint} = [];
- for my $maint (@maints) {
- if (defined $maint and $maint eq '' and not $unmaintained_packages) {
- $unmaintained_packages = 1;
- our %maintainers = %{getmaintainers()};
- $param{function} = [(exists $param{function}?
- (ref $param{function}?@{$param{function}}:$param{function}):()),
- sub {my %d=@_;
- foreach my $try (make_list($d{"pkg"})) {
- next unless length $try;
- ($try) = $try =~ m/^(?:src:)?(.+)/;
- return 1 if not exists $maintainers{$try};
- }
- return 0;
- }
- ];
- }
- elsif (defined $maint and $maint ne '') {
- push @{$param{maint}},$maint;
- }
- }
- # We handle src packages, maint and maintenc by mapping to the
- # appropriate binary packages, then removing all packages which
- # don't match all queries
- my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
- qw(package src maint)
- );
- if (exists $param{package} or
- exists $param{src} or
- exists $param{maint}) {
- delete @param{qw(maint src)};
- $param{package} = [@packages] if @packages;
- }
- my $grep_bugs = 0;
- my %bugs;
- if (exists $param{bugs}) {
- $bugs{$_} = 1 for make_list($param{bugs});
- $grep_bugs = 1;
- }
- # These queries have to be handled by get_bugs_by_idx
- if (exists $param{owner}
- or exists $param{correspondent}
- or exists $param{affects}) {
- $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
- qw(owner correspondent affects),
- );
- $grep_bugs = 1;
- }
- my @bugs;
- BUG: while (<$flatfile>) {
- next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
- my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
- next if $grep_bugs and not exists $bugs{$bug};
- if (exists $param{package}) {
- my @packages = splitpackages($pkg);
- next unless grep { my $pkg_list = $_;
- grep {$pkg_list eq $_} make_list($param{package})
- } @packages;
- }
- if (exists $param{src}) {
- my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
- my @packages = splitpackages($pkg);
- next unless grep { my $pkg_list = $_;
- grep {$pkg_list eq $_} @packages
- } @src_packages;
- }
- if (exists $param{submitter}) {
- my @p_addrs = map {lc($_->address)}
- map {getparsedaddrs($_)}
- make_list($param{submitter});
- my @f_addrs = map {$_->address}
- getparsedaddrs($submitter||'');
- next unless grep { my $f_addr = $_;
- grep {$f_addr eq $_} @p_addrs
- } @f_addrs;
- }
- next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
- next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
- if (exists $param{tag}) {
- my $bug_ok = 0;
- # either a normal tag, or a usertag must be set
- $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
- my @bug_tags = split ' ', $tags;
- $bug_ok = 1 if grep {my $bug_tag = $_;
- grep {$bug_tag eq $_} make_list($param{tag});
- } @bug_tags;
- next unless $bug_ok;
- }
- # We do this last, because a function may be slow...
- if (exists $param{function}) {
- my @bug_tags = split ' ', $tags;
- my @packages = splitpackages($pkg);
- my $package = (@packages > 1)?\@packages:$packages[0];
- for my $function (make_list($param{function})) {
- next BUG unless
- $function->(pkg => $package,
- bug => $bug,
- status => $status,
- submitter => $submitter,
- severity => $severity,
- tags => \@bug_tags,
- );
- }
- }
- push @bugs, $bug;
- }
- return @bugs;
-}
-
-=head1 PRIVATE FUNCTIONS
-
-=head2 __handle_pkg_src_and_maint
-
- my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
- qw(package src maint)
- );
-
-Turn package/src/maint into a list of packages
-
-=cut
-
-sub __handle_pkg_src_and_maint{
- my %param = validate_with(params => \@_,
- spec => {package => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- src => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maint => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- },
- allow_extra => 1,
- );
-
- my @packages;
- @packages = make_list($param{package}) if exists $param{package};
- my $package_keys = @packages?1:0;
- my %packages;
- @packages{@packages} = (1) x @packages;
- if (exists $param{src}) {
- # We only want to increment the number of keys if there is
- # something to match
- my $key_inc = 0;
- # in case there are binaries with the same name as the
- # source
- my %_temp_p = ();
- for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
- $packages{$package}++ unless exists $_temp_p{$package};
- $_temp_p{$package} = 1;
- $key_inc=1;
- }
- for my $package (make_list($param{src})) {
- $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
- $_temp_p{"src:$package"} = 1;
- $key_inc=1;
- # As a temporary hack, we will also include $param{src}
- # in this list for packages passed which do not have a
- # corresponding binary package
- if (not exists getpkgsrc()->{$package}) {
- $packages{$package}++ unless exists $_temp_p{$package};
- $_temp_p{$package} = 1;
- }
- }
- $package_keys += $key_inc;
- }
- if (exists $param{maint}) {
- my $key_inc = 0;
- my %_temp_p = ();
- for my $package (package_maintainer(maintainer=>$param{maint})) {
- $packages{$package}++ unless exists $_temp_p{$package};
- $_temp_p{$package} = 1;
- $key_inc = 1;
- }
- $package_keys += $key_inc;
- }
- return grep {$packages{$_} >= $package_keys} keys %packages;
-}
-
-state $field_match = {
- 'subject' => \&__contains_field_match,
- 'tags' => sub {
- my ($field, $values, $status) = @_;
- my %values = map {$_=>1} @$values;
- foreach my $t (split /\s+/, $status->{$field}) {
- return 1 if (defined $values{$t});
- }
- return 0;
- },
- 'severity' => \&__exact_field_match,
- 'pending' => \&__exact_field_match,
- 'package' => \&__exact_field_match,
- 'originator' => \&__contains_field_match,
- 'forwarded' => \&__contains_field_match,
- 'owner' => \&__contains_field_match,
-};
-
-sub __bug_matches {
- my ($hash, $status) = @_;
- foreach my $key( keys( %$hash ) ) {
- my $value = $hash->{$key};
- next unless exists $field_match->{$key};
- my $sub = $field_match->{$key};
- if (not defined $sub) {
- die "No defined subroutine for key: $key";
- }
- return 1 if ($sub->($key, $value, $status));
- }
- return 0;
-}
-
-sub __exact_field_match {
- my ($field, $values, $status) = @_;
- my @values = @$values;
- my @ret = grep {$_ eq $status->{$field} } @values;
- $#ret != -1;
-}
-
-sub __contains_field_match {
- my ($field, $values, $status) = @_;
- foreach my $data (@$values) {
- return 1 if (index($status->{$field}, $data) > -1);
- }
- return 0;
-}
-
-
-
-
-
-1;
-
-__END__
diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm
deleted file mode 100644
index 7dabb1e..0000000
--- a/Debbugs/CGI.pm
+++ /dev/null
@@ -1,1014 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007 by Don Armstrong .
-
-package Debbugs::CGI;
-
-=head1 NAME
-
-Debbugs::CGI -- General routines for the cgi scripts
-
-=head1 SYNOPSIS
-
-use Debbugs::CGI qw(:url :html);
-
-=head1 DESCRIPTION
-
-This module is a replacement for parts of common.pl; subroutines in
-common.pl will be gradually phased out and replaced with equivalent
-(or better) functionality here.
-
-=head1 BUGS
-
-None known.
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-use feature qw(state);
-
-our %URL_PARAMS = ();
-
-BEGIN{
- ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink),
- qw(set_url_params version_url),
- qw(submitterurl mainturl munge_url),
- qw(package_links bug_links),
- ],
- html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
- qw(maybelink htmlize_addresslinks htmlize_maintlinks),
- ],
- util => [qw(cgi_parameters quitcgi),
- ],
- forms => [qw(option_form form_options_and_normal_param)],
- usertags => [qw(add_user)],
- misc => [qw(maint_decode)],
- package_search => [qw(@package_search_key_order %package_search_keys)],
- cache => [qw(calculate_etag etag_does_not_match)],
- #status => [qw(getbugstatus)],
- );
- @EXPORT_OK = ();
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-use Debbugs::URI;
-use URI::Escape;
-use HTML::Entities;
-use Debbugs::Common qw(getparsedaddrs make_list);
-use Params::Validate qw(validate_with :types);
-
-use Debbugs::Config qw(:config);
-use Debbugs::Status qw(splitpackages isstrongseverity);
-use Debbugs::User qw();
-
-use Mail::Address;
-use POSIX qw(ceil);
-use Storable qw(dclone);
-use Scalar::Util qw(looks_like_number);
-
-use List::AllUtils qw(max);
-use File::stat;
-use Digest::MD5 qw(md5_hex);
-use Carp;
-
-use Debbugs::Text qw(fill_in_template);
-
-
-
-=head2 set_url_params
-
- set_url_params($uri);
-
-
-Sets the url params which will be used to generate urls.
-
-=cut
-
-sub set_url_params{
- if (@_ > 1) {
- %URL_PARAMS = @_;
- }
- else {
- my $url = Debbugs::URI->new($_[0]||'');
- %URL_PARAMS = %{$url->query_form_hash};
- }
-}
-
-
-=head2 munge_url
-
- my $url = munge_url($url,%params_to_munge);
-
-Munges a url, replacing parameters with %params_to_munge as appropriate.
-
-=cut
-
-sub munge_url {
- my $url = shift;
- my %params = @_;
- my $new_url = Debbugs::URI->new($url);
- my @old_param = $new_url->query_form();
- my @new_param;
- while (my ($key,$value) = splice @old_param,0,2) {
- push @new_param,($key,$value) unless exists $params{$key};
- }
- $new_url->query_form(@new_param,
- map {($_,$params{$_})}
- sort keys %params);
- return $new_url->as_string;
-}
-
-
-=head2 version_url
-
- version_url(package => $package,found => $found,fixed => $fixed)
-
-Creates a link to the version cgi script
-
-=over
-
-=item package -- source package whose graph to display
-
-=item found -- arrayref of found versions
-
-=item fixed -- arrayref of fixed versions
-
-=item format -- optional image format override
-
-=item width -- optional width of graph
-
-=item height -- optional height of graph
-
-=item info -- display html info surrounding graph; defaults to 1 if
-width and height are not passed.
-
-=item collapse -- whether to collapse the graph; defaults to 1 if
-width and height are passed.
-
-=back
-
-=cut
-
-sub version_url{
- my %params = validate_with(params => \@_,
- spec => {package => {type => SCALAR|ARRAYREF,
- },
- found => {type => ARRAYREF,
- default => [],
- },
- fixed => {type => ARRAYREF,
- default => [],
- },
- format => {type => SCALAR,
- optional => 1,
- },
- width => {type => SCALAR,
- optional => 1,
- },
- height => {type => SCALAR,
- optional => 1,
- },
- absolute => {type => BOOLEAN,
- default => 0,
- },
- collapse => {type => BOOLEAN,
- default => 1,
- },
- info => {type => BOOLEAN,
- optional => 1,
- },
- }
- );
- if (not defined $params{width} and not defined $params{height}) {
- $params{info} = 1 if not exists $params{info};
- }
- my $url = Debbugs::URI->new('version.cgi?');
- $url->query_form(%params);
- return $url->as_string;
-}
-
-=head2 html_escape
-
- html_escape($string)
-
-Escapes html entities by calling HTML::Entities::encode_entities;
-
-=cut
-
-sub html_escape{
- my ($string) = @_;
-
- return HTML::Entities::encode_entities($string,q(<>&"'));
-}
-
-=head2 cgi_parameters
-
- cgi_parameters
-
-Returns all of the cgi_parameters from a CGI script using CGI::Simple
-
-=cut
-
-sub cgi_parameters {
- my %options = validate_with(params => \@_,
- spec => {query => {type => OBJECT,
- can => 'param',
- },
- single => {type => ARRAYREF,
- default => [],
- },
- default => {type => HASHREF,
- default => {},
- },
- },
- );
- my $q = $options{query};
- my %single;
- @single{@{$options{single}}} = (1) x @{$options{single}};
- my %param;
- for my $paramname ($q->param) {
- if ($single{$paramname}) {
- $param{$paramname} = $q->param($paramname);
- }
- else {
- $param{$paramname} = [$q->param($paramname)];
- }
- }
- for my $default (keys %{$options{default}}) {
- if (not exists $param{$default}) {
- # We'll clone the reference here to avoid surprises later.
- $param{$default} = ref($options{default}{$default})?
- dclone($options{default}{$default}):$options{default}{$default};
- }
- }
- return %param;
-}
-
-
-sub quitcgi {
- my ($msg, $status) = @_;
- $status //= '500 Internal Server Error';
- print "Status: $status\n";
- print "Content-Type: text/html\n\n";
- print fill_in_template(template=>'cgi/quit',
- variables => {msg => $msg}
- );
- exit 0;
-}
-
-
-=head1 HTML
-
-=head2 htmlize_packagelinks
-
- htmlize_packagelinks
-
-Given a scalar containing a list of packages separated by something
-that L can separate, returns a
-formatted set of links to packages in html.
-
-=cut
-
-sub htmlize_packagelinks {
- my ($pkgs) = @_;
- return '' unless defined $pkgs and $pkgs ne '';
- my @pkglist = splitpackages($pkgs);
-
- carp "htmlize_packagelinks is deprecated, use package_links instead";
-
- return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
- package_links(package =>\@pkglist,
- class => 'submitter'
- );
-}
-
-=head2 package_links
-
- join(', ', package_links(packages => \@packages))
-
-Given a list of packages, return a list of html which links to the package
-
-=over
-
-=item package -- arrayref or scalar of package(s)
-
-=item submitter -- arrayref or scalar of submitter(s)
-
-=item src -- arrayref or scalar of source(s)
-
-=item maintainer -- arrayref or scalar of maintainer(s)
-
-=item links_only -- return only links, not htmlized links, defaults to
-returning htmlized links.
-
-=item class -- class of the a href, defaults to ''
-
-=back
-
-=cut
-
-our @package_search_key_order = (package => 'in package',
- tag => 'tagged',
- severity => 'with severity',
- src => 'in source package',
- maint => 'in packages maintained by',
- submitter => 'submitted by',
- owner => 'owned by',
- status => 'with status',
- affects => 'which affect package',
- correspondent => 'with mail from',
- newest => 'newest bugs',
- bugs => 'in bug',
- );
-our %package_search_keys = @package_search_key_order;
-our %package_links_invalid_options =
- map {($_,1)} (keys %package_search_keys,
- qw(msg att));
-
-sub package_links {
- state $spec =
- {(map { ($_,{type => SCALAR|ARRAYREF,
- optional => 1,
- });
- } keys %package_search_keys,
- ## these are aliases for package
- ## search keys
- source => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- maintainer => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- ),
- links_only => {type => BOOLEAN,
- default => 0,
- },
- class => {type => SCALAR,
- default => '',
- },
- separator => {type => SCALAR,
- default => ', ',
- },
- options => {type => HASHREF,
- default => {},
- },
- };
- my %param = validate_with(params => \@_,
- spec => $spec,
- );
- my %options = %{$param{options}};
- for (grep {$package_links_invalid_options{$_}} keys %options) {
- delete $options{$_};
- }
- ## remove aliases for source and maintainer
- if (exists $param{source}) {
- $param{src} = [exists $param{src}?make_list($param{src}):(),
- make_list($param{source}),
- ];
- delete $param{source};
- }
- if (exists $param{maintainer}) {
- $param{maint} = [exists $param{maint}?make_list($param{maint}):(),
- make_list($param{maintainer}),
- ];
- delete $param{maintainer};
- }
- my $has_options = keys %options;
- my @links = ();
- for my $type (qw(src package)) {
- next unless exists $param{$type};
- for my $target (make_list($param{$type})) {
- my $t_type = $type;
- if ($target =~ s/^src://) {
- $t_type = 'source';
- } elsif ($t_type eq 'source') {
- $target = 'src:'.$target;
- }
- if ($has_options) {
- push @links,
- (munge_url('pkgreport.cgi?',
- %options,
- $t_type => $target,
- ),
- $target);
- } else {
- push @links,
- ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target),
- $target);
- }
- }
- }
- for my $type (qw(maint owner submitter correspondent)) {
- next unless exists $param{$type};
- for my $target (make_list($param{$type})) {
- if ($has_options) {
- push @links,
- (munge_url('pkgreport.cgi?',
- %options,
- $type => $target),
- $target);
- } else {
- push @links,
- ('pkgreport.cgi?'.
- $type.'='.uri_escape_utf8($target),
- $target);
- }
- }
- }
- my @return = ();
- my ($link,$link_name);
- my $class = '';
- if (length $param{class}) {
- $class = q( class=").html_escape($param{class}).q(");
- }
- while (($link,$link_name) = splice(@links,0,2)) {
- if ($param{links_only}) {
- push @return,$link
- }
- else {
- push @return,
- qq().
- html_escape($link_name).q();
- }
- }
- if (wantarray) {
- return @return;
- }
- else {
- return join($param{separator},@return);
- }
-}
-
-=head2 bug_links
-
- join(', ', bug_links(bug => \@packages))
-
-Given a list of bugs, return a list of html which links to the bugs
-
-=over
-
-=item bug -- arrayref or scalar of bug(s)
-
-=item links_only -- return only links, not htmlized links, defaults to
-returning htmlized links.
-
-=item class -- class of the a href, defaults to ''
-
-=back
-
-=cut
-
-sub bug_links {
- state $spec = {bug => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- links_only => {type => BOOLEAN,
- default => 0,
- },
- class => {type => SCALAR,
- default => '',
- },
- separator => {type => SCALAR,
- default => ', ',
- },
- options => {type => HASHREF,
- default => {},
- },
- };
- my %param = validate_with(params => \@_,
- spec => $spec,
- );
- my %options = %{$param{options}};
-
- for (qw(bug)) {
- delete $options{$_} if exists $options{$_};
- }
- my $has_options = keys %options;
- my @links;
- if ($has_options) {
- push @links, map {(munge_url('bugreport.cgi?',
- %options,
- bug => $_,
- ),
- $_);
- } make_list($param{bug}) if exists $param{bug};
- } else {
- push @links,
- map {my $b = ceil($_);
- ('bugreport.cgi?bug='.$b,
- $b)}
- grep {looks_like_number($_)}
- make_list($param{bug}) if exists $param{bug};
- }
- my @return;
- my ($link,$link_name);
- my $class = '';
- if (length $param{class}) {
- $class = q( class=").html_escape($param{class}).q(");
- }
- while (($link,$link_name) = splice(@links,0,2)) {
- if ($param{links_only}) {
- push @return,$link
- }
- else {
- push @return,
- qq().
- html_escape($link_name).q();
- }
- }
- if (wantarray) {
- return @return;
- }
- else {
- return join($param{separator},@return);
- }
-}
-
-
-
-=head2 maybelink
-
- maybelink($in);
- maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
- maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
-
-
-In the first form, links the link if it looks like a link. In the
-second form, first splits based on the regex, then reassembles the
-link, linking things that look like links. In the third form, rejoins
-the split links with commas and spaces.
-
-=cut
-
-sub maybelink {
- my ($links,$regex,$join) = @_;
- if (not defined $regex and not defined $join) {
- $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
- {html_escape($1).(length $2?q().html_escape($2).q():'').html_escape($3)}geimo;
- return $links;
- }
- $join = ' ' if not defined $join;
- my @return;
- my @segments;
- if (defined $regex) {
- @segments = split $regex, $links;
- }
- else {
- @segments = ($links);
- }
- for my $in (@segments) {
- if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
- push @return, qq{} . html_escape($in) . '';
- } else {
- push @return, html_escape($in);
- }
- }
- return @return?join($join,@return):'';
-}
-
-
-=head2 htmlize_addresslinks
-
- htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
-
-
-Generate a comma-separated list of HTML links to each address given in
-$addresses, which should be a comma-separated list of RFC822
-addresses. $urlfunc should be a reference to a function like mainturl
-or submitterurl which returns the URL for each individual address.
-
-
-=cut
-
-sub htmlize_addresslinks {
- my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
- carp "htmlize_addresslinks is deprecated";
-
- $class = defined $class?qq(class="$class" ):'';
- if (defined $addresses and $addresses ne '') {
- my @addrs = getparsedaddrs($addresses);
- my $prefix = (ref $prefixfunc) ?
- $prefixfunc->(scalar @addrs):$prefixfunc;
- return $prefix .
- join(', ', map
- { sprintf qq(%s',
- $urlfunc->($_->address),
- html_escape($_->format) ||
- '(unknown)'
- } @addrs
- );
- }
- else {
- my $prefix = (ref $prefixfunc) ?
- $prefixfunc->(1) : $prefixfunc;
- return sprintf '%s(unknown)',
- $prefix, $urlfunc->('');
- }
-}
-
-sub emailfromrfc822{
- my $addr = getparsedaddrs($_[0] || "");
- $addr = defined $addr?$addr->address:'';
- return $addr;
-}
-
-sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
-sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
-sub htmlize_maintlinks {
- my ($prefixfunc, $maints) = @_;
- carp "htmlize_maintlinks is deprecated";
- return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
-}
-
-=head2 bug_linklist
-
- bug_linklist($separator,$class,@bugs)
-
-Creates a set of links to C<@bugs> separated by C<$separator> with
-link class C<$class>.
-
-XXX Use L; we want to be able to support query
-arguments here too; we should be able to combine bug_links and this
-function into one.
-
-=cut
-
-
-sub bug_linklist{
- my ($sep,$class,@bugs) = @_;
- carp "bug_linklist is deprecated; use bug_links instead";
- return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
-}
-
-
-sub add_user {
- my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
- $seen_users = {} if not defined $seen_users;
- $bug_usertags = {} if not defined $bug_usertags;
- $usertags = {} if not defined $usertags;
- $cats = {} if not defined $cats;
- $hidden = {} if not defined $hidden;
- return if exists $seen_users->{$user};
- $seen_users->{$user} = 1;
-
- my $u = Debbugs::User::get_user($user);
-
- my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
- for my $c (keys %{$u->{"categories"}}) {
- $cats->{$c} = $u->{"categories"}->{$c};
- $hidden->{$c} = 1 unless defined $vis{$c};
- }
- for my $t (keys %{$u->{"tags"}}) {
- $usertags->{$t} = [] unless defined $usertags->{$t};
- push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
- }
-
- %{$bug_usertags} = ();
- for my $t (keys %{$usertags}) {
- for my $b (@{$usertags->{$t}}) {
- $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
- push @{$bug_usertags->{$b}}, $t;
- }
- }
-}
-
-
-
-=head1 Forms
-
-=cut
-
-=head2 form_options_and_normal_param
-
- my ($form_option,$param) = form_options_and_normal_param(\%param)
- if $param{form_options};
- my $form_option = form_options_and_normal_param(\%param)
- if $param{form_options};
-
-Translates from special form_options to a set of parameters which can
-be used to run the current page.
-
-The idea behind this is to allow complex forms to relatively easily
-cause options that the existing cgi scripts understand to be set.
-
-Currently there are two commands which are understood:
-combine, and concatenate.
-
-=head3 combine
-
-Combine works by entering key,value pairs into the parameters using
-the key field option input field, and the value field option input
-field.
-
-For example, you would have
-
-
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
-
-
-
-would yield foo=>'bar' in %param.
-
-=head3 concatenate
-
-Concatenate concatenates values into a single entry in a parameter
-
-For example, you would have
-
-
-
-which would combine the _fo_searchkey and _fo_searchvalue input fields, so
-
-
-
-
-would yield foo=>'bar:baz' in %param.
-
-
-=cut
-
-my $form_option_leader = '_fo_';
-sub form_options_and_normal_param{
- my ($orig_param) = @_;
- # all form_option parameters start with _fo_
- my ($param,$form_option) = ({},{});
- for my $key (keys %{$orig_param}) {
- if ($key =~ /^\Q$form_option_leader\E/) {
- $form_option->{$key} = $orig_param->{$key};
- }
- else {
- $param->{$key} = $orig_param->{$key};
- }
- }
- # at this point, we check for commands
- COMMAND: for my $key (keys %{$form_option}) {
- $key =~ s/^\Q$form_option_leader\E//;
- if (my ($key_name,$value_name) =
- $key =~ /combine_key(\Q$form_option_leader\E.+)
- _value(\Q$form_option_leader\E.+)$/x
- ) {
- next unless defined $form_option->{$key_name};
- next unless defined $form_option->{$value_name};
- my @keys = make_list($form_option->{$key_name});
- my @values = make_list($form_option->{$value_name});
- for my $i (0 .. $#keys) {
- last if $i > $#values;
- next if not defined $keys[$i];
- next if not defined $values[$i];
- __add_to_param($param,
- $keys[$i],
- $values[$i],
- );
- }
- }
- elsif (my ($field,$concatenate_key,$fields) =
- $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
- ((?:\Q$form_option_leader\E.+?)+)
- $/x
- ) {
- if (length $concatenate_key) {
- $concatenate_key =~ s/_with_//;
- }
- else {
- $concatenate_key = ':';
- }
- my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
- my %field_list;
- my $max_num = 0;
- for my $f (@fields) {
- next COMMAND unless defined $form_option->{$f};
- $field_list{$f} = [make_list($form_option->{$f})];
- $max_num = max($max_num,$#{$field_list{$f}});
- }
- for my $i (0 .. $max_num) {
- next unless @fields == grep {$i <= $#{$field_list{$_}} and
- defined $field_list{$_}[$i]} @fields;
- __add_to_param($param,
- $field,
- join($concatenate_key,
- map {$field_list{$_}[$i]} @fields
- )
- );
- }
- }
- }
- return wantarray?($form_option,$param):$form_option;
-}
-
-=head2 option_form
-
- print option_form(template=>'pkgreport_options',
- param => \%param,
- form_options => $form_options,
- )
-
-
-
-=cut
-
-sub option_form{
- my %param = validate_with(params => \@_,
- spec => {template => {type => SCALAR,
- },
- variables => {type => HASHREF,
- default => {},
- },
- language => {type => SCALAR,
- optional => 1,
- },
- param => {type => HASHREF,
- default => {},
- },
- form_options => {type => HASHREF,
- default => {},
- },
- },
- );
-
- # First, we need to see if we need to add particular types of
- # parameters
- my $variables = dclone($param{variables});
- $variables->{param} = dclone($param{param});
- for my $key (keys %{$param{form_option}}) {
- # strip out leader; shouldn't be anything here without one,
- # but skip stupid things anyway
- next unless $key =~ s/^\Q$form_option_leader\E//;
- if ($key =~ /^add_(.+)$/) {
- # this causes a specific parameter to be added
- __add_to_param($variables->{param},
- $1,
- ''
- );
- }
- elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
- next unless exists $variables->{param}{$1};
- if (ref $variables->{param}{$1} eq 'ARRAY' and
- defined $2 and
- defined $variables->{param}{$1}[$2]
- ) {
- splice @{$variables->{param}{$1}},$2,1;
- }
- else {
- delete $variables->{param}{$1};
- }
- }
- # we'll add extra comands here once I figure out what they
- # should be
- }
- # now at this point, we're ready to create the template
- return Debbugs::Text::fill_in_template(template=>$param{template},
- (exists $param{language}?(language=>$param{language}):()),
- variables => $variables,
- hole_var => {'&html_escape' => \&html_escape,
- },
- );
-}
-
-sub __add_to_param{
- my ($param,$key,@values) = @_;
-
- if (exists $param->{$key} and not
- ref $param->{$key}) {
- @{$param->{$key}} = [$param->{$key},
- @values
- ];
- }
- else {
- push @{$param->{$key}}, @values;
- }
-}
-
-
-
-=head1 misc
-
-=cut
-
-=head2 maint_decode
-
- maint_decode
-
-Decodes the funky maintainer encoding.
-
-Don't ask me what in the world it does.
-
-=cut
-
-sub maint_decode {
- my @input = @_;
- return () unless @input;
- my @output;
- for my $input (@input) {
- my $decoded = $input;
- $decoded =~ s/-([^_]+)/-$1_-/g;
- $decoded =~ s/_/-20_/g;
- $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
- $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
- $decoded =~ s/\./-2e_/g;
- $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
- push @output,$decoded;
- }
- wantarray ? @output : $output[0];
-}
-
-=head1 cache
-
-=head2 calculate_etags
-
- calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
-
-=cut
-
-sub calculate_etags {
- my %param =
- validate_with(params => \@_,
- spec => {files => {type => ARRAYREF,
- default => [],
- },
- additional_data => {type => ARRAYREF,
- default => [],
- },
- },
- );
- my @additional_data = @{$param{additional_data}};
- for my $file (@{$param{files}}) {
- my $st = stat($file) or warn "Unable to stat $file: $!";
- push @additional_data,$st->mtime;
- push @additional_data,$st->size;
- }
- return(md5_hex(join('',sort @additional_data)));
-}
-
-=head2 etag_does_not_match
-
- etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
- additional_data=>[qw(any additional data)])
-
-
-Checks to see if the CGI request contains an etag which matches the calculated
-etag.
-
-If there wasn't an etag given, or the etag given doesn't match, return the etag.
-
-If the etag does match, return 0.
-
-=cut
-
-sub etag_does_not_match {
- my %param =
- validate_with(params => \@_,
- spec => {files => {type => ARRAYREF,
- default => [],
- },
- additional_data => {type => ARRAYREF,
- default => [],
- },
- cgi => {type => OBJECT},
- },
- );
- my $submitted_etag =
- $param{cgi}->http('if-none-match');
- my $etag =
- calculate_etags(files=>$param{files},
- additional_data=>$param{additional_data});
- if (not defined $submitted_etag or
- length($submitted_etag) != 32
- or $etag ne $submitted_etag
- ) {
- return $etag;
- }
- if ($etag eq $submitted_etag) {
- return 0;
- }
-}
-
-
-1;
-
-
-__END__
-
-
-
-
-
-
diff --git a/Debbugs/CGI/Bugreport.pm b/Debbugs/CGI/Bugreport.pm
deleted file mode 100644
index a606394..0000000
--- a/Debbugs/CGI/Bugreport.pm
+++ /dev/null
@@ -1,507 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later version. See the
-# file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# be listed here too.]
-# Copyright 2008 by Don Armstrong .
-
-
-package Debbugs::CGI::Bugreport;
-
-=head1 NAME
-
-Debbugs::CGI::Bugreport -- specific routines for the bugreport cgi script
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-
-=head1 BUGS
-
-None known.
-
-=cut
-
-use warnings;
-use strict;
-use utf8;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-use IO::Scalar;
-use Params::Validate qw(validate_with :types);
-use Digest::MD5 qw(md5_hex);
-use Debbugs::Mail qw(get_addresses :reply);
-use Debbugs::MIME qw(decode_rfc1522 create_mime_message parse_to_mime_entity);
-use Debbugs::CGI qw(:url :html :util);
-use Debbugs::Common qw(globify_scalar english_join hash_slice);
-use Debbugs::UTF8;
-use Debbugs::Config qw(:config);
-use Debbugs::Log qw(:read);
-use POSIX qw(strftime);
-use Encode qw(decode_utf8 encode_utf8);
-use URI::Escape qw(uri_escape_utf8);
-use Scalar::Util qw(blessed);
-use List::AllUtils qw(sum);
-use File::Temp;
-
-BEGIN{
- ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = ();
- @EXPORT_OK = (qw(display_entity handle_record handle_email_message));
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-
-
-=head2 display_entity
-
- display_entity(entity => $entity,
- bug_num => $ref,
- outer => 1,
- msg_num => $msg_num,
- attachments => \@attachments,
- output => \$output);
-
-
-=over
-
-=item entity -- MIME::Parser entity
-
-=item bug_num -- Bug number
-
-=item outer -- Whether this is the outer entity; defaults to 1
-
-=item msg_num -- message number in the log
-
-=item attachments -- arrayref of attachments
-
-=item output -- scalar reference for output
-
-=back
-
-=cut
-
-sub display_entity {
- my %param = validate_with(params => \@_,
- spec => {entity => {type => OBJECT,
- },
- bug_num => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- outer => {type => BOOLEAN,
- default => 1,
- },
- msg_num => {type => SCALAR,
- },
- attachments => {type => ARRAYREF,
- default => [],
- },
- output => {type => SCALARREF|HANDLE,
- default => \*STDOUT,
- },
- terse => {type => BOOLEAN,
- default => 0,
- },
- msg => {type => SCALAR,
- optional => 1,
- },
- att => {type => SCALAR,
- optional => 1,
- },
- trim_headers => {type => BOOLEAN,
- default => 1,
- },
- avatars => {type => BOOLEAN,
- default => 1,
- },
- }
- );
-
- my $output = globify_scalar($param{output});
- my $entity = $param{entity};
- my $ref = $param{bug_num};
- my $xmessage = $param{msg_num};
- my $attachments = $param{attachments};
-
- my $head = $entity->head;
- my $disposition = $head->mime_attr('content-disposition');
- $disposition = 'inline' if not defined $disposition or $disposition eq '';
- my $type = $entity->effective_type;
- my $filename = $entity->head->recommended_filename;
- $filename = '' unless defined $filename;
- $filename = decode_rfc1522($filename);
-
- if ($param{outer} and
- not $param{terse} and
- not exists $param{att}) {
- print {$output} "
\n";
- if ($param{trim_headers}) {
- my @headers;
- foreach (qw(From To Cc Subject Date)) {
- my $head_field = $head->get($_);
- next unless defined $head_field and $head_field ne '';
- chomp $head_field;
- if ($_ eq 'From' and $param{avatars}) {
- my $libravatar_url = __libravatar_url(decode_rfc1522($head_field));
- if (defined $libravatar_url and length $libravatar_url) {
- push @headers,q(\n);
- }
- }
- push @headers, qq(
\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} '
\n";
- }
- } elsif (not $param{terse}) {
- my $content_type = $entity->head->get('Content-Type:') || "text/html";
- my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
- my $body = $entity->bodyhandle->as_string;
- $body = convert_to_utf8($body,$charset//'utf8');
- $body = html_escape($body);
- my $css_class = "message";
- # Attempt to deal with format=flowed
- if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) {
- $body =~ s{^\ }{}mgo;
- # we ignore the other things that you can do with
- # flowed e-mails cause they don't really matter.
- $css_class .= " flowed";
- }
-
- # if the message is composed entirely of lines which are separated by
- # newlines, wrap it. [Allow the signature to have special formatting.]
- if ($body =~ /^([^\n]+\n\n)*[^\n]*\n?(-- \n.+)*$/s or
- # if the first 20 lines in the message which have any non-space
- # characters are larger than 100 characters more often than they
- # are not, then use CSS to try to impose sensible wrapping
- sum(0,map {length ($_) > 100?1:-1} grep {/\S/} split /\n/,$body,20) > 0
- ) {
- $css_class .= " wrapping";
- }
- # Add links to URLs
- # We don't html escape here because we escape above;
- # wierd terminators are because of that
- $body =~ s{((?:ftp|http|https|svn|ftps|rsync)://[\S~-]+?/?) # Url
- ((?:\>\;)?[)]?(?:'|\&\#39\;|\"\;)?[:.\,]?(?:\s|$)) # terminators
- }{$1$2}gox;
- # Add links to bug closures
- $body =~ s[((?:closes|see):\s* # start of closed/referenced bugs
- (?:bug)?\#?\s?\d+\s? # first bug
- (?:,?\s*(?:bug)?\#?\s?\d+)* # additional bugs
- (?:\s|\n|\)|\]|\}|\.|\,|$)) # ends with a space, newline, end of string, or ); fixes #747267
- ]
- [my $temp = $1;
- $temp =~ s{(\d+)}
- {bug_links(bug=>$1)}ge;
- $temp;]gxie;
- if (defined $config{cve_tracker} and
- length $config{cve_tracker}
- ) {
- # Add links to CVE vulnerabilities (closes #568464)
- $body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)}
- {$1$2$3}gxm;
- }
- if (not exists $param{att}) {
- print {$output} qq(
$body
\n);
- }
- }
- return 0;
-}
-
-
-=head2 handle_email_message
-
- handle_email_message($record->{text},
- ref => $bug_number,
- msg_num => $msg_number,
- );
-
-Returns a decoded e-mail message and displays entities/attachments as
-appropriate.
-
-
-=cut
-
-sub handle_email_message{
- my ($record,%param) = @_;
-
- my $output;
- my $output_fh = globify_scalar(\$output);
- my $entity;
- my $tempdir;
- if (not blessed $record) {
- $entity = parse_to_mime_entity($record);
- } else {
- $entity = $record;
- }
- my @attachments = ();
- my $raw_output =
- display_entity(entity => $entity,
- bug_num => $param{ref},
- outer => 1,
- msg_num => $param{msg_num},
- output => $output_fh,
- attachments => \@attachments,
- terse => $param{terse},
- hash_slice(%param,qw(msg att trim_headers avatars),
- ),
- );
- return $raw_output?$output:decode_utf8($output);
-}
-
-=head2 handle_record
-
- push @log, handle_record($record,$ref,$msg_num);
-
-Deals with a record in a bug log as returned by
-L; returns the log information that
-should be output to the browser.
-
-=cut
-
-sub handle_record{
- my ($record,$bug_number,$msg_number,$seen_msg_ids,%param) = @_;
-
- # output needs to have the is_utf8 flag on to avoid double
- # encoding
- my $output = decode_utf8('');
- local $_ = $record->{type};
- if (/html/) {
- # $record->{text} is not in perl's internal encoding; convert it
- my $text = decode_rfc1522(decode_utf8(record_text($record)));
- my ($time) = $text =~ //;
- my $class = $text =~ /^(?:Acknowledgement|Information|Report|Notification)/m ? 'infmessage':'msgreceived';
- $output .= $text;
- # Link to forwarded http:// urls in the midst of the report
- # (even though these links already exist at the top)
- $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)((?:[\)\'\:\.\,]|\&\#39;|\"\;)?
- (?:\s|\.<|$)),$1$2,gxo;
- # Add links to the cloned bugs
- $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>(defined $5)?[$4..$5]:$4)}eo;
- # Add links to merged bugs
- $output =~ s{(?<=Merged )([\d\s]+)(?=[\.<])}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo;
- # Add links to blocked bugs
- $output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
- {(defined $2?$1.bug_links(bug=>$2):'').$3.
- english_join([map {bug_links(bug=>$_)} (split /\,?\s+/, $4)])}eo;
- $output =~ s{((?:[Aa]dded|[Rr]emoved)\ blocking\ bug(?:\(s\))?)(?:(\ of\ )(\d+))?(:?\s+)
- (\d+(?:,\s+\d+)*(?:\,?\s+and\s+\d+)?)}
- {$1.(defined $3?$2.bug_links(bug=>$3):'').$4.
- english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}xeo;
- $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks ?)([\d\s\,]+)}
- {$1.$2.(bug_links(bug=>$3)).$4.
- english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}eo;
- # Add links to reassigned packages
- $output =~ s{($config{bug}\sreassigned\sfrom\spackage\s(?:[\`']|\&\#39;))([^']+?)((?:'|\&\#39;|\"\;)
- \sto\s(?:[\`']|\&\#39;|\"\;))([^']+?)((?:'|\&\#39;|\"\;))}
- {$1.package_links(package=>$2).$3.
- package_links(package=>$4).$5}exo;
- if (defined $time) {
- $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') ';
- }
- $output .= qq{(full text, mbox, '.
- qq{link).
};
-
- $output = qq(
\n\n) . $output . "
\n";
- }
- elsif (/recips/) {
- my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i);
- if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
- return ();
- }
- elsif (defined $msg_id) {
- $$seen_msg_ids{$msg_id} = 1;
- }
- return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
- $output .= qq(
';
- $output .= handle_email_message($record,
- ref => $bug_number,
- msg_num => $msg_number,
- %param,
- );
- }
- elsif (/autocheck/) {
- # Do nothing
- }
- elsif (/incoming-recv/) {
- my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i);
- if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) {
- return ();
- }
- elsif (defined $msg_id) {
- $$seen_msg_ids{$msg_id} = 1;
- }
- return () if defined $param{spam} and $param{spam}->is_spam($msg_id);
- # Incomming Mail Message
- my ($received,$hostname) = record_regex($record,qr/Received: \(at (\S+)\) by (\S+)\;/o);
- $output .= qq|
Message #$msg_number received at |.
- html_escape("$received\@$hostname") .
- q| (full text'.
- q|, mbox, ';
- my $parser = MIME::Parser->new();
-
- # this will be cleaned up once it goes out of scope
- my $tempdir = File::Temp->newdir();
- $parser->output_under($tempdir->dirname());
- $parser->filer->ignore_filename(1);
- my $entity;
- if ($record->{inner_file}) {
- $entity = $parser->parse($record->{fh});
- } else {
- $entity = $parser->parse_data($record->{text});
- }
- my $r_l = reply_headers($entity);
- $output .= q(reply);
-
- $output .= ')'.":
\n";
- $output .= handle_email_message($entity,
- ref => $bug_number,
- msg_num => $msg_number,
- %param,
- );
- }
- else {
- die "Unknown record type $_";
- }
- return $output;
-}
-
-
-sub __libravatar_url {
- my ($email) = @_;
- if (not defined $config{libravatar_uri} or not length $config{libravatar_uri}) {
- return undef;
- }
- ($email) = grep {/\@/} get_addresses($email);
- return $config{libravatar_uri}.uri_escape_utf8($email.($config{libravatar_uri_options}//''));
-}
-
-
-1;
-
-
-__END__
-# Local Variables:
-# cperl-indent-level: 4
-# indent-tabs-mode: nil
-# End:
diff --git a/Debbugs/CGI/Pkgreport.pm b/Debbugs/CGI/Pkgreport.pm
deleted file mode 100644
index e3dcc12..0000000
--- a/Debbugs/CGI/Pkgreport.pm
+++ /dev/null
@@ -1,654 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later version. See the
-# file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# be listed here too.]
-# Copyright 2008 by Don Armstrong .
-
-
-package Debbugs::CGI::Pkgreport;
-
-=head1 NAME
-
-Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-
-=head1 BUGS
-
-None known.
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-
-use IO::Scalar;
-use Params::Validate qw(validate_with :types);
-
-use Debbugs::Collection::Bug;
-
-use Carp;
-use List::AllUtils qw(apply);
-
-use Debbugs::Config qw(:config :globals);
-use Debbugs::CGI qw(:url :html :util);
-use Debbugs::Common qw(:misc :util :date);
-use Debbugs::Status qw(:status);
-use Debbugs::Bugs qw(bug_filter);
-use Debbugs::Packages qw(:mapping);
-
-use Debbugs::Text qw(:templates);
-use Encode qw(decode_utf8);
-
-use POSIX qw(strftime);
-
-
-BEGIN{
- ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs),
- ],
- misc => [qw(generate_package_info),
- qw(determine_ordering),
- ],
- );
- @EXPORT_OK = (qw());
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-=head2 generate_package_info
-
- generate_package_info($srcorbin,$package)
-
-Generates the informational bits for a package and returns it
-
-=cut
-
-sub generate_package_info{
- my %param = validate_with(params => \@_,
- spec => {binary => {type => BOOLEAN,
- default => 1,
- },
- package => {type => SCALAR,#|ARRAYREF,
- },
- options => {type => HASHREF,
- },
- bugs => {type => ARRAYREF,
- },
- schema => {type => OBJECT,
- optional => 1,
- },
- },
- );
-
- my $output_scalar = '';
- my $output = globify_scalar(\$output_scalar);
-
- my $package = $param{package};
-
- my %pkgsrc = %{getpkgsrc()};
- my $srcforpkg = $package;
- if ($param{binary}) {
- $srcforpkg =
- binary_to_source(source_only => 1,
- scalar_only => 1,
- binary => $package,
- hash_slice(%param,qw(schema)),
- );
- }
-
- my $showpkg = html_escape($package);
- my @maint = package_maintainer($param{binary}?'binary':'source',
- $package,
- hash_slice(%param,qw(schema)),
- );
- if (@maint) {
- print {$output} '
';
- print {$output} (@maint > 1? "Maintainer for $showpkg is "
- : "Maintainers for $showpkg are ") .
- package_links(maintainer => \@maint);
- print {$output} ".
\n";
- }
- else {
- print {$output} "
There is no maintainer for $showpkg. ".
- "This means that this package no longer exists (or never existed). ".
- "Please do not report new bugs against this package.
\n";
- }
- my @pkgs = source_to_binary(source => $srcforpkg,
- hash_slice(%param,qw(schema)),
- binary_only => 1,
- # if there are distributions, only bother to
- # show packages which are currently in a
- # distribution.
- @{$config{distributions}//[]} ?
- (dist => [@{$config{distributions}}]) : (),
- ) if defined $srcforpkg;
- @pkgs = grep( !/^\Q$package\E$/, @pkgs );
- if ( @pkgs ) {
- @pkgs = sort @pkgs;
- if ($param{binary}) {
- print {$output} "
You may want to refer to the following packages that are part of the same source:\n";
- }
- else {
- print {$output} "
You may want to refer to the following individual bug pages:\n";
- }
- #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) );
- print {$output} scalar package_links(package=>[@pkgs]);
- print {$output} ".\n";
- }
- my @references;
- my $pseudodesc = getpseudodesc();
- if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) {
- push @references, "to the ".
- "list of other pseudo-packages";
- }
- else {
- if ($package and defined $config{package_pages} and length $config{package_pages}) {
- push @references, sprintf "to the %s package page",
- html_escape("$config{package_pages}/$package"), html_escape("$package");
- }
- if (defined $config{package_tracking_domain} and
- length $config{package_tracking_domain}) {
- my $ptslink = $param{binary} ? $srcforpkg : $package;
- # the pts only wants the source, and doesn't care about src: (#566089)
- $ptslink =~ s/^src://;
- push @references, q(to the Package Tracking System);
- }
- # Only output this if the source listing is non-trivial.
- if ($param{binary} and $srcforpkg) {
- push @references,
- "to the source package ".
- package_links(src=>$srcforpkg,
- options => $param{options}) .
- "'s bug page";
- }
- }
- if (@references) {
- $references[$#references] = "or $references[$#references]" if @references > 1;
- print {$output} "
You might like to refer ", join(", ", @references), ".
\n";
- }
- if (@maint) {
- print {$output} "
If you find a bug not listed here, please\n";
- printf {$output} "report it.
\n";
- for my $i (0..$#{$param{prior}}) {
- my $local_result = '';
- foreach my $key ( @{$param{order}[$i]} ) {
- my $count = $count{"g_${i}_$key"};
- next if !$count or !$param{title}[$i]->[$key];
- $local_result .= "
$count $param{title}[$i]->[$key]
\n";
- }
- if ( $local_result ) {
- $footer .= "
$param{names}[$i]
\n$local_result
\n";
- }
- }
- $footer .= "
\n
\n";
- }
-
- $result = $header . $result if ( $common{show_list_header} );
- $result .= $footer if ( $common{show_list_footer} );
- return $result;
-}
-
-sub parse_order_statement_to_subroutine {
- my ($statement) = @_;
- if (not defined $statement or not length $statement) {
- return sub {return 1};
- }
- croak "invalid statement '$statement'" unless
- $statement =~ /^(?:(package|tag|pending|severity) # field
- = # equals
- ([^=|\&,\+]+(?:,[^=|\&,+])*) #value
- (\+|,|$) # joiner or end
- )+ # one or more of these statements
- /x;
- my @sub_bits;
- while ($statement =~ /(?^|,|\+) # joiner
- (?package|tag|pending|severity) # field
- = # equals
- (?[^=|\&,\+]+(?:,[^=|\&,\+])*) #value
- /xg) {
- my $field = $+{field};
- my $value = $+{value};
- my $joiner = $+{joiner} // '';
- my @vals = apply {quotemeta($_)} split /,/,$value;
- if (length $joiner) {
- if ($joiner eq '+') {
- push @sub_bits, ' and ';
- }
- else {
- push @sub_bits, ' or ';
- }
- }
- my @vals_bits;
- for my $val (@vals) {
- if ($field =~ /package|severity/o) {
- push @vals_bits, '$_[0]->status->'.$field.
- ' eq q('.$val.')';
- } elsif ($field eq 'tag') {
- push @vals_bits, '$_[0]->tags->is_set('.
- 'q('.$val.'))';
- } elsif ($field eq 'pending') {
- push @vals_bits, '$_[0]->'.$field.
- ' eq q('.$val.')';
- }
- }
- push @sub_bits ,' ('.join(' or ',@vals_bits).') ';
- }
- # return a subroutine reference which determines whether an order statement
- # matches this bug
- my $sub = 'sub { return ('.join ("\n",@sub_bits).');};';
- my $subref = eval $sub;
- if ($@) {
- croak "Unable to generate subroutine: $@; $sub";
- }
- return $subref;
-}
-
-sub parse_order_statement_into_boolean {
- my ($statement,$status,$tags) = @_;
-
- if (not defined $tags) {
- $tags = {map { $_, 1 } split / /, $status->{"tags"}
- }
- if defined $status->{"tags"};
-
- }
- # replace all + with &&
- $statement =~ s/\+/&&/g;
- # replace all , with ||
- $statement =~ s/,/||/g;
- $statement =~ s{([^\&\|\=]+) # field
- =
- ([^\&\|\=]+) # value
- }{
- my $ok = 0;
- if ($1 eq 'tag') {
- $ok = 1 if defined $tags->{$2};
- } else {
- $ok = 1 if defined $status->{$1} and
- $status->{$1} eq $2;
- }
- $ok;
- }exg;
- # check that the parsed statement is just valid boolean statements
- if ($statement =~ /^([01\(\)\&\|]+)$/) {
- return eval "$1";
- } else {
- # this is an invalid boolean statement
- return 0;
- }
-}
-
-sub get_bug_order_index {
- my ($order,$bug) = @_;
- my $pos = 0;
- for my $el (@{$order}) {
- if ($el->($bug)) {
- return $pos;
- }
- $pos++;
- }
- return $pos;
-}
-
-# sets: my @names; my @prior; my @title; my @order;
-
-sub determine_ordering {
- my %param = validate_with(params => \@_,
- spec => {cats => {type => HASHREF,
- },
- param => {type => HASHREF,
- },
- ordering => {type => SCALARREF,
- },
- names => {type => ARRAYREF,
- },
- pend_rev => {type => BOOLEAN,
- default => 0,
- },
- sev_rev => {type => BOOLEAN,
- default => 0,
- },
- prior => {type => ARRAYREF,
- },
- title => {type => ARRAYREF,
- },
- order => {type => ARRAYREF,
- },
- },
- );
- $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ]
- if ($param{pend_rev});
- $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ]
- if ($param{sev_rev});
-
- my $i;
- if (defined $param{param}{"pri0"}) {
- my @c = ();
- $i = 0;
- while (defined $param{param}{"pri$i"}) {
- my $h = {};
-
- my ($pri) = make_list($param{param}{"pri$i"});
- if ($pri =~ m/^([^:]*):(.*)$/) {
- $h->{"nam"} = $1; # overridden later if necesary
- $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ];
- }
- else {
- $h->{"pri"} = [ split /,/, $pri ];
- }
-
- ($h->{"nam"}) = make_list($param{param}{"nam$i"})
- if (defined $param{param}{"nam$i"});
- $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ]
- if (defined $param{param}{"ord$i"});
- $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ]
- if (defined $param{param}{"ttl$i"});
-
- push @c, $h;
- $i++;
- }
- $param{cats}{"_"} = [@c];
- ${$param{ordering}} = "_";
- }
-
- ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}};
-
- sub get_ordering {
- my @res;
- my $cats = shift;
- my $o = shift;
- for my $c (@{$cats->{$o}}) {
- if (ref($c) eq "HASH") {
- push @res, $c;
- }
- else {
- push @res, get_ordering($cats, $c);
- }
- }
- return @res;
- }
- my @cats = get_ordering($param{cats}, ${$param{ordering}});
-
- sub toenglish {
- my $expr = shift;
- $expr =~ s/[+]/ and /g;
- $expr =~ s/[a-z]+=//g;
- return $expr;
- }
-
- $i = 0;
- for my $c (@cats) {
- $i++;
- push @{$param{prior}}, $c->{"pri"};
- push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i);
- if (defined $c->{"ord"}) {
- push @{$param{order}}, $c->{"ord"};
- }
- else {
- push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ];
- }
- my @t = @{ $c->{"ttl"} } if defined $c->{ttl};
- if (@t < $#{$param{prior}[-1]}) {
- push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]});
- }
- push @t, $c->{"def"} || "";
- push @{$param{title}}, [@t];
- }
-}
-
-
-
-
-1;
-
-
-__END__
-
-
-
-
-
-
diff --git a/Debbugs/Collection.pm b/Debbugs/Collection.pm
deleted file mode 100644
index 6e3d49d..0000000
--- a/Debbugs/Collection.pm
+++ /dev/null
@@ -1,390 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Collection;
-
-=head1 NAME
-
-Debbugs::Collection -- Collection base class which can generate lots of objects
-
-=head1 SYNOPSIS
-
-This base class is designed for holding collections of objects which can be
-uniquely identified by a key and added/generated by that same key.
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::autoclean;
-use List::AllUtils qw(pairmap);
-use Carp qw(croak);
-
-extends 'Debbugs::OOBase';
-
-=head1 METHODS
-
-=head2 Debbugs::Collection->new(%params|$params)
-
-Creates a new Debbugs::Collection object.
-
-Parameters:
-
-=over
-
-=item universe
-
-To avoid unnecessarily constructing new members, collections have a universe to
-which existing members can be obtained from. By default the universe is this
-collection. Generally, you should create exactly one universe for each
-collection type.
-
-=item schema
-
-Optional Debbugs::Schema object
-
-
-=back
-
-=head2 $collection->members()
-
-Returns list of members of this collection
-
-=head2 $collection->members_ref()
-
-Returns an ARRAYREF of members of this collection
-
-=head2 $collection->keys_of_members()
-
-Returns a list of the keys of all members of this collection
-
-=head2 $collection->member_key($member)
-
-Given a member, returns the key of that member
-
-=head2 $collection->exists($member_key)
-
-Returns true if a member with $member_key exists in the collection
-
-=head2 $collection->clone()
-
-Returns a clone of this collection with the same universe as this collection
-
-=head2 $collection->limit(@member_keys)
-
-Returns a new collection limited to the list of member keys passed. Will add new
-members to the universe if they do not currently exist.
-
-=head2 $collection->add($member)
-
-Add a member to this collection
-
-=head2 $collection->add_by_key($member_key)
-
-Add a member to this collection by key
-
-=head2 $collection->combine($collection2) or $collection + $collection2
-
-Combines the members of both collections together and returns the new collection
-
-=head2 $collection->get($member_key)
-
-Get member(s) by key, returning undef for keys which do not exist in the
-collection
-
-=head2 $collection->get_or_add_by_key($member_key)
-
-Get or add a member by the member key.
-
-=head2 $collection->count()
-
-Return the number of members in this collection
-
-=head2 $collection->grep({$_ eq 5})
-
-Return the members in this collection which satisfy the condition, setting $_
-locally to each member object
-
-=head2 $collection->join(', ')
-
-Returns the keys of the members of this collection joined
-
-=head2 $collection->apply({$_*2})
-
-Return the list of applying BLOCK to each member; each member can return 0 or
-more results
-
-=head2 $collection->map({$_*2})
-
-Returns the list of applying BLOCK to each member; each member should return
-exactly one result
-
-=head2 $collection->sort({$a <=> $b})
-
-Return the list of members sorted by BLOCK
-
-=cut
-
-has 'members' => (is => 'bare',
- isa => 'ArrayRef',
- traits => ['Array'],
- default => sub {[]},
- writer => '_set_members',
- predicate => '_has_members',
- handles => {_add => 'push',
- members => 'elements',
- count => 'count',
- _get_member => 'get',
- grep => 'grep',
- map => 'map',
- sort => 'sort',
- },
- );
-
-sub apply {
- my $self = shift;
- my $block = shift;
- my @r;
- for ($self->members) {
- push @r,$block->();
- }
- return @r;
-}
-
-sub members_ref {
- my $self = shift;
- return [$self->members];
-}
-
-has 'member_hash' => (traits => ['Hash'],
- is => 'bare',
- # really a HashRef[Int], but type checking is too slow
- isa => 'HashRef',
- lazy => 1,
- reader => '_member_hash',
- builder => '_build_member_hash',
- clearer => '_clear_member_hash',
- predicate => '_has_member_hash',
- writer => '_set_member_hash',
- handles => {# _add_member_hash => 'set',
- _member_key_exists => 'exists',
- _get_member_hash => 'get',
- },
- );
-
-# because _add_member_hash needs to be fast, we are overriding the default set
-# method which is very safe but slow, because it makes copies.
-sub _add_member_hash {
- my ($self,@kv) = @_;
- pairmap {
- defined($a)
- or $self->meta->
- throw_error("Hash keys passed to _add_member_hash must be defined" );
- ($b eq int($b)) or
- $self->meta->
- throw_error("Values passed to _add_member_hash must be integer");
- } @kv;
- my @return;
- while (my ($key, $value) = splice @kv, 0, 2 ) {
- push @return,
- $self->{member_hash}{$key} = $value
- }
- wantarray ? return @return: return $return[0];
-}
-
-=head2 $collection->universe
-
-
-=cut
-
-has 'universe' => (is => 'ro',
- isa => 'Debbugs::Collection',
- required => 1,
- builder => '_build_universe',
- writer => '_set_universe',
- predicate => 'has_universe',
- );
-
-sub _build_universe {
- # By default, the universe is myself
- return $_[0];
-}
-
-sub clone {
- my $self = shift;
- my $new = bless { %{$self} }, ref $self;
- if ($self->_has_members) {
- $new->_set_members([$self->members]);
- }
- if ($self->_has_member_hash) {
- $new->_set_member_hash({%{$self->_member_hash}})
- }
- return $new;
-}
-
-sub _shallow_clone {
- my $self = shift;
- return bless { %{$self} }, ref $self;
-}
-
-sub limit {
- my $self = shift;
- my $limit = $self->_shallow_clone();
- # Set the universe to whatever my universe is (potentially myself)
- # $limit->_set_universe($self->universe);
- $limit->_set_members([]);
- $limit->_clear_member_hash();
- $limit->add($self->universe->get_or_add_by_key(@_)) if @_;
- return $limit;
-}
-
-sub get_or_add_by_key {
- my $self = shift;
- return () unless @_;
- my @return;
- my @exists;
- my @need_to_add;
- for my $i (0..$#_) {
- # we assume that if it's already a blessed reference, that it's the
- # right object to return
- if (ref $_[$i]) {
- croak "Passed a reference instead of a key to get_or_add_by_key";
- }
- elsif ($self->_member_key_exists($_[$i])) {
- push @exists,$i;
- } else {
- push @need_to_add,$i;
- }
- }
- # create and add by key
- if (@need_to_add) {
- @return[@need_to_add] =
- $self->add_by_key(@_[@need_to_add]);
- }
- if (@exists) {
- @return[@exists] =
- $self->get(@_[@exists]);
- }
- # if we've only been asked to get or create one thing, then it's expected
- # that we are returning only one thing
- if (@_ == 1) {
- return $return[0];
- }
- return @return;
-}
-
-has 'constructor_args' => (is => 'rw',
- isa => 'ArrayRef',
- lazy => 1,
- builder => '_build_constructor_args',
- );
-
-sub _build_constructor_args {
- return [];
-}
-
-sub add_by_key {
- my $self = shift;
- # we'll assume that add does the right thing. around this in subclasses
- return $self->add(@_);
-}
-
-sub add {
- my $self = shift;
- my @members_added;
- for my $member (@_) {
- if (not defined $member) {
- confess("Undefined member to add");
- }
- push @members_added,$member;
- if ($self->exists($member)) {
- next;
- }
- $self->_add($member);
- $self->_add_member_hash($self->member_key($member),
- $self->count()-1,
- );
- }
- return @members_added;
-}
-
-use overload '+' => "combine",
- '""' => "CARP_TRACE";
-
-sub combine {
- my $self = shift;
- my $return = $self->clone;
- $return->add($_->members) for @_;
- return $return;
-}
-
-sub get {
- my $self = shift;
- my @res = map {$self->_get_member($_)}
- $self->_get_member_hash(@_);
- wantarray?@res:$res[0];
-}
-
-
-sub member_key {
- return $_[1];
-}
-
-sub keys_of_members {
- my $self = shift;
- return $self->map(sub {$self->member_key($_)});
-}
-
-sub exists {
- my $self = shift;
- return $self->_member_key_exists($self->member_key($_[0]));
-}
-
-sub join {
- my $self = shift;
- my $joiner = shift;
- return CORE::join($joiner,$self->keys_of_members);
-}
-
-sub _build_member_hash {
- my $self = shift;
- my $hash = {};
- my $i = 0;
- for my $member ($self->members) {
- $hash->{$self->member_key($member)} =
- $i++;
- }
- return $hash;
-}
-
-sub CARP_TRACE {
- my $self = shift;
- my @members = $self->members;
- if (@members > 5) {
- @members = map {$self->member_key($_)}
- @members[0..4];
- push @members,'...';
- } else {
- @members = map {$self->member_key($_)} @members;
- }
- return __PACKAGE__.'={n_members='.$self->count().
- ',members=('.CORE::join(',',@members).')}';
-}
-
-
-__PACKAGE__->meta->make_immutable;
-no Mouse;
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Collection/Bug.pm b/Debbugs/Collection/Bug.pm
deleted file mode 100644
index 3f40b0c..0000000
--- a/Debbugs/Collection/Bug.pm
+++ /dev/null
@@ -1,216 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Collection::Bug;
-
-=head1 NAME
-
-Debbugs::Collection::Bug -- Bug generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L and contains members of
-L. Useful for any field which contains one or more bug or tracking
-lists of packages
-
-=head1 DESCRIPTION
-
-
-
-=head1 METHODS
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::autoclean;
-use Debbugs::Common qw(make_list hash_slice);
-use Debbugs::OOTypes;
-use Debbugs::Status qw(get_bug_statuses);
-use Debbugs::Collection::Package;
-use Debbugs::Collection::Correspondent;
-
-use Debbugs::Bug;
-
-extends 'Debbugs::Collection';
-
-=head2 my $bugs = Debbugs::Collection::Bug->new(%params|$param)
-
-Parameters in addition to those defined by L
-
-=over
-
-=item package_collection
-
-Optional L which is used to look up packages
-
-
-=item correspondent_collection
-
-Optional L which is used to look up correspondents
-
-
-=item users
-
-Optional arrayref of L which set usertags for bugs in this collection
-
-=back
-
-=head2 $bugs->package_collection()
-
-Returns the package collection that this bug collection is using
-
-=head2 $bugs->correspondent_collection()
-
-Returns the correspondent collection that this bug collection is using
-
-=head2 $bugs->users()
-
-Returns the arrayref of users that this bug collection is using
-
-=head2 $bugs->add_user($user)
-
-Add a user to the set of users that this bug collection is using
-
-=head2 $bugs->load_related_packages_and_versions()
-
-Preload all of the related packages and versions for the bugs in this bug
-collection. You should call this if you plan on calculating whether the bugs in
-this collection are present/absent.
-
-=cut
-
-has '+members' => (isa => 'ArrayRef[Bug]');
-has 'package_collection' =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Package',
- builder => '_build_package_collection',
- lazy => 1,
- );
-
-sub _build_package_collection {
- my $self = shift;
- return Debbugs::Collection::Package->new($self->has_schema?(schema => $self->schema):());
-}
-
-has 'correspondent_collection' =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Correspondent',
- builder => '_build_correspondent_collection',
- lazy => 1,
- );
-
-sub _build_correspondent_collection {
- my $self = shift;
- return Debbugs::Collection::Correspondent->new($self->has_schema?(schema => $self->schema):());
-}
-
-has 'users' =>
- (is => 'ro',
- isa => 'ArrayRef[Debbugs::User]',
- traits => ['Array'],
- default => sub {[]},
- handles => {'add_user' => 'push'},
- );
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- if (exists $args->{bugs}) {
- $self->add(
- $self->_member_constructor(bugs => $args->{bugs}
- ));
- }
-}
-
-sub _member_constructor {
- # handle being called $self->_member_constructor;
- my $self = shift;
- my %args = @_;
- my @return;
- my $schema;
- $schema = $self->schema if $self->has_schema;
-
- if (defined $schema) {
- my $statuses = get_bug_statuses(bug => [make_list($args{bugs})],
- schema => $schema,
- );
- # preload as many of the packages as we need
- my %packages;
- while (my ($bug, $status) = each %{$statuses}) {
- if (defined $status->{package}) {
- $packages{$_} = 1 for split /,/, $status->{package};
- }
- if (defined $status->{source}) {
- $packages{$_} = 1 for split /,/, $status->{source};
- }
- }
- $self->package_collection->universe->add_by_key(keys %packages);
- while (my ($bug, $status) = each %{$statuses}) {
- push @return,
- Debbugs::Bug->new(bug => $bug,
- status =>
- Debbugs::Bug::Status->new(status => $status,
- bug => $bug,
- status_source => 'db',
- ),
- schema => $schema,
- package_collection =>
- $self->package_collection->universe,
- bug_collection =>
- $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- @{$args{constructor_args}//[]},
- );
- }
- } else {
- for my $bug (make_list($args{bugs})) {
- push @return,
- Debbugs::Bug->new(bug => $bug,
- package_collection =>
- $self->package_collection->universe,
- bug_collection =>
- $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- @{$args{constructor_args}//[]},
- );
- }
- }
- return @return;
-}
-
-around add_by_key => sub {
- my $orig = shift;
- my $self = shift;
- my @members =
- $self->_member_constructor(bugs => [@_],
- );
- return $self->$orig(@members);
-};
-
-sub member_key {
- return $_[1]->bug;
-}
-
-sub load_related_packages_and_versions {
- my $self = shift;
- my @related_packages_and_versions =
- $self->apply(sub {$_->related_packages_and_versions});
- $self->package_collection->
- add_packages_and_versions(@related_packages_and_versions);
-}
-
-__PACKAGE__->meta->make_immutable;
-
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Collection/Correspondent.pm b/Debbugs/Collection/Correspondent.pm
deleted file mode 100644
index 43ac8c0..0000000
--- a/Debbugs/Collection/Correspondent.pm
+++ /dev/null
@@ -1,83 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Collection::Correspondent;
-
-=head1 NAME
-
-Debbugs::Collection::Correspondent -- Bug generation factory
-
-=head1 SYNOPSIS
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::autoclean;
-use Debbugs::Common qw(make_list hash_slice);
-use Debbugs::OOTypes;
-use Debbugs::Status qw(get_bug_statuses);
-
-use Debbugs::Correspondent;
-
-extends 'Debbugs::Collection';
-
-has '+members' => (isa => 'ArrayRef[Debbugs::Correspondent]');
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- if (exists $args->{correspondent}) {
- $self->
- add($self->_member_constructor(correspondent =>
- $args->{correspondent}));
- }
-}
-
-
-sub _member_constructor {
- # handle being called $self->_member_constructor;
- my $self = shift;
- my %args = @_;
- my @return;
- for my $corr (make_list($args{correspondent})) {
- push @return,
- Debbugs::Correspondent->new(name => $corr,
- $self->schema_argument,
- );
- }
- return @return;
-}
-
-around add_by_key => sub {
- my $orig = shift;
- my $self = shift;
- my @members =
- $self->_member_constructor(correspondent => [@_],
- $self->schema_argument,
- );
- return $self->$orig(@members);
-};
-
-sub member_key {
- return $_[1]->name;
-}
-
-
-__PACKAGE__->meta->make_immutable;
-
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Collection/Package.pm b/Debbugs/Collection/Package.pm
deleted file mode 100644
index 055cbae..0000000
--- a/Debbugs/Collection/Package.pm
+++ /dev/null
@@ -1,293 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Collection::Package;
-
-=head1 NAME
-
-Debbugs::Collection::Package -- Package generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L and contains members of
-L. Useful for any field which contains one or more package or
-tracking lists of packages
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use v5.10; # for state
-use namespace::autoclean;
-
-use Carp;
-use Debbugs::Common qw(make_list hash_slice);
-use Debbugs::Config qw(:config);
-use Debbugs::OOTypes;
-use Debbugs::Package;
-
-use List::AllUtils qw(part);
-
-use Debbugs::Version::Binary;
-use Debbugs::Collection::Version;
-use Debbugs::Collection::Correspondent;
-use Debbugs::VersionTree;
-
-extends 'Debbugs::Collection';
-
-=head1 Object Creation
-
-=head2 my $packages = Debbugs::Collection::Package->new(%params|$param)
-
-Parameters in addition to those defined by L
-
-=over
-
-=item correspondent_collection
-
-Optional L which is used to look up correspondents
-
-
-=item versiontree
-
-Optional L which contains known package source versions
-
-=back
-
-=head1 Methods
-
-=head2 correspondent_collection
-
- $packages->correspondent_collection
-
-Returns the L for this package collection
-
-=head2 versiontree
-
-Returns the L for this package collection
-
-=cut
-
-has '+members' => (isa => 'ArrayRef[Debbugs::Package]');
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- if (exists $args->{packages}) {
- $self->
- add($self->_member_constructor(packages =>
- $args->{packages}));
- }
-}
-
-around add_by_key => sub {
- my $orig = shift;
- my $self = shift;
- my @members =
- $self->_member_constructor(packages => [@_]);
- return $self->$orig(@members);
-};
-
-sub _member_constructor {
- # handle being called $self->_member_constructor;
- my $self = shift;
- my %args = @_;
- my $schema;
- if ($self->has_schema) {
- $schema = $self->schema;
- }
- my @return;
- if (defined $schema) {
- if (not ref($args{packages}) or @{$args{packages}} == 1 and
- $self->universe->count() > 0
- ) {
- carp("Likely inefficiency; member_constructor called with one argument");
- }
- my $packages =
- Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages},
- schema => $schema,
- );
- for my $package (keys %{$packages}) {
- push @return,
- Debbugs::Package->new(%{$packages->{$package}},
- schema => $schema,
- package_collection => $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- );
- }
- } else {
- for my $package (make_list($args{packages})) {
- push @return,
- Debbugs::Package->new(name => $package,
- package_collection => $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- );
- }
- }
- return @return;
-}
-
-sub add_packages_and_versions {
- my $self = shift;
- $self->add($self->_member_constructor(packages => \@_));
-}
-
-
-sub member_key {
- return $_[1]->qualified_name;
-}
-
-has 'correspondent_collection' =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Correspondent',
- default => sub {Debbugs::Collection::Correspondent->new()},
- );
-
-has 'versiontree' =>
- (is => 'ro',
- isa => 'Debbugs::VersionTree',
- lazy => 1,
- builder => '_build_versiontree',
- );
-
-sub _build_versiontree {
- my $self = shift;
- return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
-}
-
-=head2 get_source_versions_distributions
-
- $packages->get_source_versions_distributions('unstable')
-
-Given a list of distributions or suites, returns a
-L of all of the versions in this package
-collection which are known to match.
-
-Effectively, this calls L for
-each package in the collection and merges the results and returns them
-
-=cut
-
-sub get_source_versions_distributions {
- my $self = shift;
- my @return;
- push @return,
- $self->map(sub {$_->get_source_version_distribution(@_)});
- if (@return > 1) {
- return $return[0]->combine($return[1..$#return]);
- }
- return @return;
-}
-
-
-=head2 get_source_versions
-
- $packages->get_source_versions('1.2.3-1','foo/1.2.3-5')
-
-Given a list of binary versions or src/versions, returns a
-L of all of the versions in this package
-collection which are known to match.
-
-If you give a binary version ('1.2.3-1'), you must have already loaded source
-packages into this package collection for it to find an appropriate match.
-
-If no package is known to match, an version which is invalid will be returned
-
-For fully qualified versions this loads the appropriate source package into the
-universe of this collection and calls L.
-For unqualified versions, calls L; if no
-valid versions are returned, creates an invalid version.
-
-=cut
-
-sub get_source_versions {
- my $self = shift;
- my @return;
- for my $ver (@_) {
- my $sv;
- if ($ver =~ m{(?.+?)/(?.+)$}) {
- my $sp = $self->universe->
- get_or_add_by_key('src:'.$+{src});
- push @return,
- $sp->get_source_version($+{ver});
- next;
- } else {
- my $found_valid = 0;
- for my $p ($self->members) {
- local $_;
- my @vs =
- grep {$_->is_valid}
- $p->get_source_version($ver);
- if (@vs) {
- $found_valid = 1;
- push @return,@vs;
- next;
- }
- }
- if (not $found_valid) {
- push @return,
- Debbugs::Version::Binary->new(version => $ver,
- package_collection => $self->universe,
- valid => 0,
- $self->schema_argument,
- );
- }
- }
- }
- return
- Debbugs::Collection::Version->new(members => \@return,
- $self->schema_argument,
- package_collection => $self->universe,
- );
-}
-
-=head2 source_names
-
- $packages->source_names()
-
-Returns a unique list of source names from all members of this collection by
-calling L on each member.
-
-=cut
-
-sub source_names {
- my $self = shift;
- local $_;
- return uniq map {$_->source_names} $self->members;
-}
-
-=head2 sources
-
- $packages->sources()
-
-Returns a L limited to source packages
-corresponding to all packages in this collection
-
-=cut
-
-sub sources {
- my $self = shift;
- return $self->universe->limit($self->source_names);
-}
-
-
-__PACKAGE__->meta->make_immutable;
-no Mouse;
-
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Collection/Version.pm b/Debbugs/Collection/Version.pm
deleted file mode 100644
index f461afe..0000000
--- a/Debbugs/Collection/Version.pm
+++ /dev/null
@@ -1,148 +0,0 @@
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong .
-
-package Debbugs::Collection::Version;
-
-=head1 NAME
-
-Debbugs::Collection::Version -- Version generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L and contains members of
-L. Useful for any field which contains package versions.
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use v5.10; # for state
-use namespace::autoclean;
-use Debbugs::Common qw(make_list hash_slice);
-use Debbugs::Config qw(:config);
-use Debbugs::OOTypes;
-use Debbugs::Version;
-
-use List::AllUtils qw(part);
-
-extends 'Debbugs::Collection';
-
-=head2 my $bugs = Debbugs::Collection::version->new(%params|$param)
-
-Parameters in addition to those defined by L
-
-=over
-
-=item package_collection
-
-Optional L which is used to look up packages
-
-=item versions
-
-Optional arrayref of C string triples
-
-=back
-
-=cut
-
-has '+members' => (isa => 'ArrayRef[Debbugs::Version]');
-
-has 'package_collection' =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Package',
- builder => '_build_package_collection',
- lazy => 1,
- );
-
-sub _build_package_collection {
- my $self = shift;
- return Debbugs::Collection::Package->new($self->schema_argument);
-}
-
-sub member_key {
- my ($self,$v) = @_;
- confess("v not defined") unless defined $v;
- return $v->package.'/'.$v->version.'/'.$v->arch;
-}
-
-
-around add_by_key => sub {
- my $orig = shift;
- my $self = shift;
- my @members =
- $self->_member_constructor(versions => [@_]);
- return $self->$orig(@members);
-};
-
-sub _member_constructor {
- my $self = shift;
- my %args = @_;
- my @return;
- for my $pkg_ver_arch (make_list($args{versions})) {
- my ($pkg,$ver,$arch) = $pkg_ver_arch =~ m{^([^/]+)/([^/]+)/?([^/]*)$} or
- confess("Invalid version key: $pkg_ver_arch");
- if ($pkg =~ s/^src://) {
- $arch = 'source';
- }
- if (not length $arch) {
- $arch = 'any';
- }
- if ($arch eq 'source') {
- push @return,
- Debbugs::Version::Source->
- new($self->schema_argument,
- package => $pkg,
- version => $ver,
- );
- } else {
- push @return,
- Debbugs::Version::Binary->
- new($self->schema_argument,
- package => $pkg,
- version => $ver,
- arch => [$arch],
- );
- }
- }
- return @return;
-}
-
-=head2 $versions->universe
-
-Unlike most collections, Debbugs::Collection::Version do not have a universe.
-
-=cut
-
-sub universe {
- return $_[0];
-}
-
-=head2 $versions->source
-
-Returns a (potentially duplicated) list of source packages which are part of
-this version collection
-
-=cut
-
-sub source {
- my $self = shift;
- return $self->map(sub{$_->source});
-}
-
-__PACKAGE__->meta->make_immutable;
-
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Command.pm b/Debbugs/Command.pm
deleted file mode 100644
index c68dd70..0000000
--- a/Debbugs/Command.pm
+++ /dev/null
@@ -1,101 +0,0 @@
-# This module is part of debbugs, and is released under the terms of
-# the GPL version 3, or any later version (at your option). See the
-# file README and COPYING for more information.
-# Copyright 2017 by Don Armstrong .
-
-package Debbugs::Command;
-
-=head1 NAME
-
-Debbugs::Command -- Handle multiple subcommand-style commands
-
-=head1 SYNOPSIS
-
- use Debbugs::Command;
-
-=head1 DESCRIPTION
-
-
-=head1 BUGS
-
-None known.
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use base qw(Exporter);
-
-BEGIN{
- $VERSION = '0.1';
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = (commands => [qw(handle_main_arguments),
- qw(handle_subcommand_arguments)
- ],
- );
- @EXPORT_OK = ();
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-
-}
-
-use Getopt::Long qw(:config no_ignore_case);
-use Pod::Usage qw(pod2usage);
-
-=head1 Command processing (:commands)
-
-Functions which parse arguments for commands (exportable with
-C<:commands>)
-
-=over
-
-=item handle_main_arguments(
-
-=cut
-
-sub handle_main_arguments {
- my ($options,@args) = @_;
- Getopt::Long::Configure('pass_through');
- GetOptions($options,@args);
- Getopt::Long::Configure('default');
- return $options;
-}
-
-
-
-sub handle_subcommand_arguments {
- my ($argv,$args,$subopt) = @_;
- $subopt //= {};
- Getopt::Long::GetOptionsFromArray($argv,
- $subopt,
- keys %{$args},
- );
- my @usage_errors;
- for my $arg (keys %{$args}) {
- next unless $args->{$arg};
- my $r_arg = $arg; # real argument name
- $r_arg =~ s/[=\|].+//g;
- if (not defined $subopt->{$r_arg}) {
- push @usage_errors, "You must give a $r_arg option";
- }
- }
- pod2usage(join("\n",@usage_errors)) if @usage_errors;
- return $subopt;
-}
-
-=back
-
-=cut
-
-
-1;
-
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm
deleted file mode 100644
index b135c42..0000000
--- a/Debbugs/Common.pm
+++ /dev/null
@@ -1,1238 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# [Other people have contributed to this file; their copyrights should
-# go here too.]
-# Copyright 2007 by Don Armstrong .
-
-package Debbugs::Common;
-
-=head1 NAME
-
-Debbugs::Common -- Common routines for all of Debbugs
-
-=head1 SYNOPSIS
-
-use Debbugs::Common qw(:url :html);
-
-
-=head1 DESCRIPTION
-
-This module is a replacement for the general parts of errorlib.pl.
-subroutines in errorlib.pl will be gradually phased out and replaced
-with equivalent (or better) functionality here.
-
-=head1 FUNCTIONS
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
-use Exporter qw(import);
-use v5.10;
-
-BEGIN{
- $VERSION = 1.00;
- $DEBUG = 0 unless defined $DEBUG;
-
- @EXPORT = ();
- %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
- qw(appendfile overwritefile buglog getparsedaddrs getmaintainers),
- qw(getsourcemaintainers getsourcemaintainers_reverse),
- qw(bug_status),
- qw(getmaintainers_reverse),
- qw(getpseudodesc),
- qw(package_maintainer),
- qw(sort_versions),
- qw(open_compressed_file),
- qw(walk_bugs),
- ],
- misc => [qw(make_list globify_scalar english_join checkpid),
- qw(cleanup_eval_fail),
- qw(hash_slice),
- ],
- date => [qw(secs_to_english)],
- quit => [qw(quit)],
- lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)],
- );
- @EXPORT_OK = ();
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
-}
-
-#use Debbugs::Config qw(:globals);
-
-use Carp;
-$Carp::Verbose = 1;
-
-use Debbugs::Config qw(:config);
-use IO::File;
-use IO::Scalar;
-use Debbugs::MIME qw(decode_rfc1522);
-use Mail::Address;
-use Cwd qw(cwd);
-use Storable qw(dclone);
-use Time::HiRes qw(usleep);
-use File::Path qw(mkpath);
-use File::Basename qw(dirname);
-use MLDBM qw(DB_File Storable);
-$MLDBM::DumpMeth='portable';
-use List::AllUtils qw(natatime);
-
-use Params::Validate qw(validate_with :types);
-
-use Fcntl qw(:DEFAULT :flock);
-use Encode qw(is_utf8 decode_utf8);
-
-our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
-
-=head1 UTILITIES
-
-The following functions are exported by the C<:util> tag
-
-=head2 getbugcomponent
-
- my $file = getbugcomponent($bug_number,$extension,$location)
-
-Returns the path to the bug file in location C<$location>, bug number
-C<$bugnumber> and extension C<$extension>
-
-=cut
-
-sub getbugcomponent {
- my ($bugnum, $ext, $location) = @_;
-
- if (not defined $location) {
- $location = getbuglocation($bugnum, $ext);
- # Default to non-archived bugs only for now; CGI scripts want
- # archived bugs but most of the backend scripts don't. For now,
- # anything that is prepared to accept archived bugs should call
- # getbuglocation() directly first.
- return undef if defined $location and
- ($location ne 'db' and $location ne 'db-h');
- }
- my $dir = getlocationpath($location);
- return undef if not defined $dir;
- if (defined $location and $location eq 'db') {
- return "$dir/$bugnum.$ext";
- } else {
- my $hash = get_hashname($bugnum);
- return "$dir/$hash/$bugnum.$ext";
- }
-}
-
-=head2 getbuglocation
-
- getbuglocation($bug_number,$extension)
-
-Returns the the location in which a particular bug exists; valid
-locations returned currently are archive, db-h, or db. If the bug does
-not exist, returns undef.
-
-=cut
-
-sub getbuglocation {
- my ($bugnum, $ext) = @_;
- my $archdir = get_hashname($bugnum);
- return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
- return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
- return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
- return undef;
-}
-
-
-=head2 getlocationpath
-
- getlocationpath($location)
-
-Returns the path to a specific location
-
-=cut
-
-sub getlocationpath {
- my ($location) = @_;
- if (defined $location and $location eq 'archive') {
- return "$config{spool_dir}/archive";
- } elsif (defined $location and $location eq 'db') {
- return "$config{spool_dir}/db";
- } else {
- return "$config{spool_dir}/db-h";
- }
-}
-
-
-=head2 get_hashname
-
- get_hashname
-
-Returns the hash of the bug which is the location within the archive
-
-=cut
-
-sub get_hashname {
- return "" if ( $_[ 0 ] < 0 );
- return sprintf "%02d", $_[ 0 ] % 100;
-}
-
-=head2 buglog
-
- buglog($bugnum);
-
-Returns the path to the logfile corresponding to the bug.
-
-Returns undef if the bug does not exist.
-
-=cut
-
-sub buglog {
- my $bugnum = shift;
- my $location = getbuglocation($bugnum, 'log');
- return getbugcomponent($bugnum, 'log', $location) if ($location);
- $location = getbuglocation($bugnum, 'log.gz');
- return getbugcomponent($bugnum, 'log.gz', $location) if ($location);
- return undef;
-}
-
-=head2 bug_status
-
- bug_status($bugnum)
-
-
-Returns the path to the summary file corresponding to the bug.
-
-Returns undef if the bug does not exist.
-
-=cut
-
-sub bug_status{
- my ($bugnum) = @_;
- my $location = getbuglocation($bugnum, 'summary');
- return getbugcomponent($bugnum, 'summary', $location) if ($location);
- return undef;
-}
-
-=head2 appendfile
-
- appendfile($file,'data','to','append');
-
-Opens a file for appending and writes data to it.
-
-=cut
-
-sub appendfile {
- my ($file,@data) = @_;
- my $fh = IO::File->new($file,'a') or
- die "Unable top open $file for appending: $!";
- print {$fh} @data or die "Unable to write to $file: $!";
- close $fh or die "Unable to close $file: $!";
-}
-
-=head2 overwritefile
-
- ovewritefile($file,'data','to','append');
-
-Opens file.new, writes data to it, then moves file.new to file.
-
-=cut
-
-sub overwritefile {
- my ($file,@data) = @_;
- my $fh = IO::File->new("${file}.new",'w') or
- die "Unable top open ${file}.new for writing: $!";
- print {$fh} @data or die "Unable to write to ${file}.new: $!";
- close $fh or die "Unable to close ${file}.new: $!";
- rename("${file}.new",$file) or
- die "Unable to rename ${file}.new to $file: $!";
-}
-
-=head2 open_compressed_file
-
- my $fh = open_compressed_file('foo.gz') or
- die "Unable to open compressed file: $!";
-
-
-Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate
-decompression program is forked and output from it is read.
-
-This routine by default opens the file with UTF-8 encoding; if you want some
-other encoding, specify it with the second option.
-
-=cut
-sub open_compressed_file {
- my ($file,$encoding) = @_;
- $encoding //= ':encoding(UTF-8)';
- my $fh;
- my $mode = "<$encoding";
- my @opts;
- if ($file =~ /\.gz$/) {
- $mode = "-|$encoding";
- push @opts,'gzip','-dc';
- }
- if ($file =~ /\.xz$/) {
- $mode = "-|$encoding";
- push @opts,'xz','-dc';
- }
- if ($file =~ /\.bz2$/) {
- $mode = "-|$encoding";
- push @opts,'bzip2','-dc';
- }
- open($fh,$mode,@opts,$file);
- return $fh;
-}
-
-=head2 walk_bugs
-
-Walk through directories of bugs, calling a subroutine with a list of bugs
-found.
-
-C sub {print map {qq($_\n)} @_},dirs => [qw(db-h)];>
-
-=over
-
-=item callback -- CODEREF of a subroutine to call with a list of bugs
-
-=item dirs -- ARRAYREF of directories to get bugs from. Like C<[qw(db-h archive)]>.
-
-=item bugs -- ARRAYREF of bugs to walk through. If both C and C are
-provided, both are walked through.
-
-=item bugs_per_call -- maximum number of bugs to provide to callback
-
-=item progress_bar -- optional L
-
-=item bug_file -- bug file to look for (generally C)
-
-=item logging -- optional filehandle to output logging information
-
-=back
-
-=cut
-
-sub walk_bugs {
- state $spec =
- {dirs => {type => ARRAYREF,
- default => [],
- },
- bugs => {type => ARRAYREF,
- default => [],
- },
- progress_bar => {type => OBJECT|UNDEF,
- optional => 1,
- },
- bug_file => {type => SCALAR,
- default => 'summary',
- },
- logging => {type => HANDLE,
- optional => 1,
- },
- callback => {type => CODEREF,
- },
- bugs_per_call => {type => SCALAR,
- default => 1,
- },
- };
- my %param = validate_with(params => \@_,
- spec => $spec
- );
- my @dirs = @{$param{dirs}};
- my @initial_bugs = ();
- if (@{$param{bugs}}) {
- unshift @dirs,'';
- @initial_bugs = @{$param{bugs}};
- }
- my $tot_dirs = @dirs;
- my $done_dirs = 0;
- my $avg_subfiles = 0;
- my $completed_files = 0;
- my $dir;
- while ($dir = shift @dirs or defined $dir) {
- my @list;
- my @subdirs;
- if (not length $dir and @initial_bugs) {
- push @list,@initial_bugs;
- @initial_bugs = ();
- } else {
- printf {$param{verbose}} "Doing dir %s ...\n", $dir
- if defined $param{verbose};
- opendir(my $DIR, "$dir/.") or
- die "opendir $dir: $!";
- @subdirs = readdir($DIR) or
- die "Unable to readdir $dir: $!";
- closedir($DIR) or
- die "Unable to closedir $dir: $!";
-
- @list = map { m/^(\d+)\.$param{bug_file}$/?($1):() } @subdirs;
- }
- $tot_dirs -= @dirs;
- push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
- $tot_dirs += @dirs;
- if ($param{progress_bar}) {
- if ($avg_subfiles == 0) {
- $avg_subfiles = @list;
- }
- $param{progress_bar}->
- target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list);
- $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
- $done_dirs += 1;
- }
-
- my $it = natatime $param{bugs_per_call},@list;
- while (my @bugs = $it->()) {
- $param{callback}->(@bugs);
- $completed_files += scalar @bugs;
- if ($param{progress_bar}) {
- $param{progress_bar}->update($completed_files) if $param{progress_bar};
- }
- if ($completed_files % 100 == 0 and
- defined $param{verbose}) {
- print {$param{verbose}} "Up to $completed_files bugs...\n"
- }
- }
- }
- $param{progress_bar}->remove() if $param{progress_bar};
-}
-
-
-=head2 getparsedaddrs
-
- my $address = getparsedaddrs($address);
- my @address = getparsedaddrs($address);
-
-Returns the output from Mail::Address->parse, or the cached output if
-this address has been parsed before. In SCALAR context returns the
-first address parsed.
-
-=cut
-
-
-our %_parsedaddrs;
-sub getparsedaddrs {
- my $addr = shift;
- return () unless defined $addr;
- return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
- if exists $_parsedaddrs{$addr};
- {
- # don't display the warnings from Mail::Address->parse
- local $SIG{__WARN__} = sub { };
- @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
- }
- return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
-}
-
-=head2 getmaintainers
-
- my $maintainer = getmaintainers()->{debbugs}
-
-Returns a hashref of package => maintainer pairs.
-
-=cut
-
-our $_maintainer = undef;
-our $_maintainer_rev = undef;
-sub getmaintainers {
- return $_maintainer if defined $_maintainer;
- package_maintainer(rehash => 1);
- return $_maintainer;
-}
-
-=head2 getmaintainers_reverse
-
- my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]};
-
-Returns a hashref of maintainer => [qw(list of packages)] pairs.
-
-=cut
-
-sub getmaintainers_reverse{
- return $_maintainer_rev if defined $_maintainer_rev;
- package_maintainer(rehash => 1);
- return $_maintainer_rev;
-}
-
-=head2 getsourcemaintainers
-
- my $maintainer = getsourcemaintainers()->{debbugs}
-
-Returns a hashref of src_package => maintainer pairs.
-
-=cut
-
-our $_source_maintainer = undef;
-our $_source_maintainer_rev = undef;
-sub getsourcemaintainers {
- return $_source_maintainer if defined $_source_maintainer;
- package_maintainer(rehash => 1);
- return $_source_maintainer;
-}
-
-=head2 getsourcemaintainers_reverse
-
- my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]};
-
-Returns a hashref of maintainer => [qw(list of source packages)] pairs.
-
-=cut
-
-sub getsourcemaintainers_reverse{
- return $_source_maintainer_rev if defined $_source_maintainer_rev;
- package_maintainer(rehash => 1);
- return $_source_maintainer_rev;
-}
-
-=head2 package_maintainer
-
- my @s = package_maintainer(source => [qw(foo bar baz)],
- binary => [qw(bleh blah)],
- );
-
-=over
-
-=item source -- scalar or arrayref of source package names to return
-maintainers for, defaults to the empty arrayref.
-
-=item binary -- scalar or arrayref of binary package names to return
-maintainers for; automatically returns source package maintainer if
-the package name starts with 'src:', defaults to the empty arrayref.
-
-=item maintainer -- scalar or arrayref of maintainers to return source packages
-for. If given, binary and source cannot be given.
-
-=item rehash -- whether to reread the maintainer and source maintainer
-files; defaults to 0
-
-=item schema -- Debbugs::DB schema. If set, uses the database for maintainer
-information.
-
-=back
-
-=cut
-
-sub package_maintainer {
- my %param = validate_with(params => \@_,
- spec => {source => {type => SCALAR|ARRAYREF,
- default => [],
- },
- binary => {type => SCALAR|ARRAYREF,
- default => [],
- },
- maintainer => {type => SCALAR|ARRAYREF,
- default => [],
- },
- rehash => {type => BOOLEAN,
- default => 0,
- },
- reverse => {type => BOOLEAN,
- default => 0,
- },
- schema => {type => OBJECT,
- optional => 1,
- }
- },
- );
- my @binary = make_list($param{binary});
- my @source = make_list($param{source});
- my @maintainers = make_list($param{maintainer});
- if ((@binary or @source) and @maintainers) {
- croak "It is nonsensical to pass both maintainers and source or binary";
- }
- if (@binary) {
- @source = grep {/^src:/} @binary;
- @binary = grep {!/^src:/} @binary;
- }
- # remove leading src: from source package names
- s/^src:// foreach @source;
- if ($param{schema}) {
- my $s = $param{schema};
- if (@maintainers) {
- my $m_rs = $s->resultset('SrcPkg')->
- search({'correspondent.addr' => [@maintainers]},
- {join => {src_vers =>
- {maintainer =>
- 'correspondent'},
- },
- columns => ['pkg'],
- group_by => [qw(me.pkg)],
- });
- return $m_rs->get_column('pkg')->all();
- } elsif (@binary or @source) {
- my $rs = $s->resultset('Maintainer');
- if (@binary) {
- $rs =
- $rs->search({'bin_pkg.pkg' => [@binary]},
- {join => {src_vers =>
- {bin_vers => 'bin_pkg'},
- },
- columns => ['name'],
- group_by => [qw(me.name)],
- }
- );
- }
- if (@source) {
- $rs =
- $rs->search({'src_pkg.pkg' => [@source]},
- {join => {src_vers =>
- 'src_pkg',
- },
- columns => ['name'],
- group_by => [qw(me.name)],
- }
- );
- }
- return $rs->get_column('name')->all();
- }
- return ();
- }
- if ($param{rehash}) {
- $_source_maintainer = undef;
- $_source_maintainer_rev = undef;
- $_maintainer = undef;
- $_maintainer_rev = undef;
- }
- if (not defined $_source_maintainer or
- not defined $_source_maintainer_rev) {
- $_source_maintainer = {};
- $_source_maintainer_rev = {};
- if (-e $config{spool_dir}.'/source_maintainers.idx' and
- -e $config{spool_dir}.'/source_maintainers_reverse.idx'
- ) {
- tie %{$_source_maintainer},
- MLDBM => $config{spool_dir}.'/source_maintainers.idx',
- O_RDONLY or
- die "Unable to tie source maintainers: $!";
- tie %{$_source_maintainer_rev},
- MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx',
- O_RDONLY or
- die "Unable to tie source maintainers reverse: $!";
- } else {
- for my $fn (@config{('source_maintainer_file',
- 'source_maintainer_file_override',
- 'pseudo_maint_file')}) {
- next unless defined $fn and length $fn;
- if (not -e $fn) {
- warn "Missing source maintainer file '$fn'";
- next;
- }
- __add_to_hash($fn,$_source_maintainer,
- $_source_maintainer_rev);
- }
- }
- }
- if (not defined $_maintainer or
- not defined $_maintainer_rev) {
- $_maintainer = {};
- $_maintainer_rev = {};
- if (-e $config{spool_dir}.'/maintainers.idx' and
- -e $config{spool_dir}.'/maintainers_reverse.idx'
- ) {
- tie %{$_maintainer},
- MLDBM => $config{spool_dir}.'/binary_maintainers.idx',
- O_RDONLY or
- die "Unable to tie binary maintainers: $!";
- tie %{$_maintainer_rev},
- MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx',
- O_RDONLY or
- die "Unable to binary maintainers reverse: $!";
- } else {
- for my $fn (@config{('maintainer_file',
- 'maintainer_file_override',
- 'pseudo_maint_file')}) {
- next unless defined $fn and length $fn;
- if (not -e $fn) {
- warn "Missing maintainer file '$fn'";
- next;
- }
- __add_to_hash($fn,$_maintainer,
- $_maintainer_rev);
- }
- }
- }
- my @return;
- for my $binary (@binary) {
- if ($binary =~ /^src:/) {
- push @source,$binary;
- next;
- }
- push @return,grep {defined $_} make_list($_maintainer->{$binary});
- }
- for my $source (@source) {
- $source =~ s/^src://;
- push @return,grep {defined $_} make_list($_source_maintainer->{$source});
- }
- for my $maintainer (grep {defined $_} @maintainers) {
- push @return,grep {defined $_}
- make_list($_maintainer_rev->{$maintainer});
- push @return,map {$_ !~ /^src:/?'src:'.$_:$_}
- grep {defined $_}
- make_list($_source_maintainer_rev->{$maintainer});
- }
- return @return;
-}
-
-#=head2 __add_to_hash
-#
-# __add_to_hash($file,$forward_hash,$reverse_hash,'address');
-#
-# Reads a maintainer/source maintainer/pseudo desc file and adds the
-# maintainers from it to the forward and reverse hashref; assumes that
-# the forward is unique; makes no assumptions of the reverse.
-#
-#=cut
-
-sub __add_to_hash {
- my ($fn,$forward,$reverse,$type) = @_;
- if (ref($forward) ne 'HASH') {
- croak "__add_to_hash must be passed a hashref for the forward";
- }
- if (defined $reverse and not ref($reverse) eq 'HASH') {
- croak "if reverse is passed to __add_to_hash, it must be a hashref";
- }
- $type //= 'address';
- my $fh = IO::File->new($fn,'r') or
- croak "Unable to open $fn for reading: $!";
- binmode($fh,':encoding(UTF-8)');
- while (<$fh>) {
- chomp;
- next unless m/^(\S+)\s+(\S.*\S)\s*$/;
- my ($key,$value)=($1,$2);
- $key = lc $key;
- $forward->{$key}= $value;
- if (defined $reverse) {
- if ($type eq 'address') {
- for my $m (map {lc($_->address)} (getparsedaddrs($value))) {
- push @{$reverse->{$m}},$key;
- }
- }
- else {
- push @{$reverse->{$value}}, $key;
- }
- }
- }
-}
-
-
-=head2 getpseudodesc
-
- my $pseudopkgdesc = getpseudodesc(...);
-
-Returns the entry for a pseudo package from the
-$config{pseudo_desc_file}. In cases where pseudo_desc_file is not
-defined, returns an empty arrayref.
-
-This function can be used to see if a particular package is a
-pseudopackage or not.
-
-=cut
-
-our $_pseudodesc = undef;
-sub getpseudodesc {
- return $_pseudodesc if defined $_pseudodesc;
- $_pseudodesc = {};
- __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if
- defined $config{pseudo_desc_file} and
- length $config{pseudo_desc_file};
- return $_pseudodesc;
-}
-
-=head2 sort_versions
-
- sort_versions('1.0-2','1.1-2');
-
-Sorts versions using AptPkg::Versions::compare if it is available, or
-Debbugs::Versions::Dpkg::vercmp if it isn't.
-
-=cut
-
-our $vercmp;
-BEGIN{
- use Debbugs::Versions::Dpkg;
- $vercmp=\&Debbugs::Versions::Dpkg::vercmp;
-
-# eventually we'll use AptPkg:::Version or similar, but the current
-# implementation makes this *super* difficult.
-
-# eval {
-# use AptPkg::Version;
-# $vercmp=\&AptPkg::Version::compare;
-# };
-}
-
-sub sort_versions{
- return sort {$vercmp->($a,$b)} @_;
-}
-
-
-=head1 DATE
-
- my $english = secs_to_english($seconds);
- my ($days,$english) = secs_to_english($seconds);
-
-XXX This should probably be changed to use Date::Calc
-
-=cut
-
-sub secs_to_english{
- my ($seconds) = @_;
-
- my $days = int($seconds / 86400);
- my $years = int($days / 365);
- $days %= 365;
- my $result;
- my @age;
- push @age, "1 year" if ($years == 1);
- push @age, "$years years" if ($years > 1);
- push @age, "1 day" if ($days == 1);
- push @age, "$days days" if ($days > 1);
- $result .= join(" and ", @age);
-
- return wantarray?(int($seconds/86400),$result):$result;
-}
-
-
-=head1 LOCK
-
-These functions are exported with the :lock tag
-
-=head2 filelock
-
- filelock($lockfile);
- filelock($lockfile,$locks);
-
-FLOCKs the passed file. Use unfilelock to unlock it.
-
-Can be passed an optional $locks hashref, which is used to track which
-files are locked (and how many times they have been locked) to allow
-for cooperative locking.
-
-=cut
-
-our @filelocks;
-
-use Carp qw(cluck);
-
-sub filelock {
- # NB - NOT COMPATIBLE WITH `with-lock'
- my ($lockfile,$locks) = @_;
- if ($lockfile !~ m{^/}) {
- $lockfile = cwd().'/'.$lockfile;
- }
- # This is only here to allow for relocking bugs inside of
- # Debbugs::Control. Nothing else should be using it.
- if (defined $locks and exists $locks->{locks}{$lockfile} and
- $locks->{locks}{$lockfile} >= 1) {
- if (exists $locks->{relockable} and
- exists $locks->{relockable}{$lockfile}) {
- $locks->{locks}{$lockfile}++;
- # indicate that the bug for this lockfile needs to be reread
- $locks->{relockable}{$lockfile} = 1;
- push @{$locks->{lockorder}},$lockfile;
- return;
- }
- else {
- use Data::Dumper;
- confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]);
- }
- }
- my ($fh,$t_lockfile,$errors) =
- simple_filelock($lockfile,10,1);
- if ($fh) {
- push @filelocks, {fh => $fh, file => $lockfile};
- if (defined $locks) {
- $locks->{locks}{$lockfile}++;
- push @{$locks->{lockorder}},$lockfile;
- }
- } else {
- use Data::Dumper;
- croak "failed to get lock on $lockfile -- $errors".
- (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):'');
- }
-}
-
-=head2 simple_filelock
-
- my ($fh,$t_lockfile,$errors) =
- simple_filelock($lockfile,$count,$wait);
-
-Does a flock of lockfile. If C<$count> is zero, does a blocking lock.
-Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait>
-seconds in between.
-
-In list context, returns the lockfile filehandle, lockfile name, and
-any errors which occured.
-
-When the lockfile filehandle is undef, locking failed.
-
-These lockfiles must be unlocked manually at process end.
-
-
-=cut
-
-sub simple_filelock {
- my ($lockfile,$count,$wait) = @_;
- if (not defined $count) {
- $count = 10;
- }
- if ($count < 0) {
- $count = 0;
- }
- if (not defined $wait) {
- $wait = 1;
- }
- my $errors= '';
- my $fh;
- while (1) {
- $fh = eval {
- my $fh2 = IO::File->new($lockfile,'w')
- or die "Unable to open $lockfile for writing: $!";
- # Do a blocking lock if count is zero
- flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB))
- or die "Unable to lock $lockfile $!";
- return $fh2;
- };
- if ($@) {
- $errors .= $@;
- }
- if ($fh) {
- last;
- }
- # use usleep for fractional wait seconds
- usleep($wait * 1_000_000);
- } continue {
- last unless (--$count > 0);
- }
- if ($fh) {
- return wantarray?($fh,$lockfile,$errors):$fh
- }
- return wantarray?(undef,$lockfile,$errors):undef;
-}
-
-# clean up all outstanding locks at end time
-END {
- while (@filelocks) {
- unfilelock();
- }
-}
-
-=head2 simple_unlockfile
-
- simple_unlockfile($fh,$lockfile);
-
-
-=cut
-
-sub simple_unlockfile {
- my ($fh,$lockfile) = @_;
- flock($fh,LOCK_UN)
- or warn "Unable to unlock lockfile $lockfile: $!";
- close($fh)
- or warn "Unable to close lockfile $lockfile: $!";
- unlink($lockfile)
- or warn "Unable to unlink lockfile $lockfile: $!";
-}
-
-
-=head2 unfilelock
-
- unfilelock()
- unfilelock($locks);
-
-Unlocks the file most recently locked.
-
-Note that it is not currently possible to unlock a specific file
-locked with filelock.
-
-=cut
-
-sub unfilelock {
- my ($locks) = @_;
- if (@filelocks == 0) {
- carp "unfilelock called with no active filelocks!\n";
- return;
- }
- if (defined $locks and ref($locks) ne 'HASH') {
- croak "hash not passsed to unfilelock";
- }
- if (defined $locks and exists $locks->{lockorder} and
- @{$locks->{lockorder}} and
- exists $locks->{locks}{$locks->{lockorder}[-1]}) {
- my $lockfile = pop @{$locks->{lockorder}};
- $locks->{locks}{$lockfile}--;
- if ($locks->{locks}{$lockfile} > 0) {
- return
- }
- delete $locks->{locks}{$lockfile};
- }
- my %fl = %{pop(@filelocks)};
- simple_unlockfile($fl{fh},$fl{file});
-}
-
-
-=head2 lockpid
-
- lockpid('/path/to/pidfile');
-
-Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the
-pid in the file does not respond to kill 0.
-
-Returns 1 on success, false on failure; dies on unusual errors.
-
-=cut
-
-sub lockpid {
- my ($pidfile) = @_;
- if (-e $pidfile) {
- my $pid = checkpid($pidfile);
- die "Unable to read pidfile $pidfile: $!" if not defined $pid;
- return 0 if $pid != 0;
- unlink $pidfile or
- die "Unable to unlink stale pidfile $pidfile $!";
- }
- mkpath(dirname($pidfile));
- my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or
- die "Unable to open $pidfile for writing: $!";
- print {$pidfh} $$ or die "Unable to write to $pidfile $!";
- close $pidfh or die "Unable to close $pidfile $!";
- return 1;
-}
-
-=head2 checkpid
-
- checkpid('/path/to/pidfile');
-
-Checks a pid file and determines if the process listed in the pidfile
-is still running. Returns the pid if it is, 0 if it isn't running, and
-undef if the pidfile doesn't exist or cannot be read.
-
-=cut
-
-sub checkpid{
- my ($pidfile) = @_;
- if (-e $pidfile) {
- my $pidfh = IO::File->new($pidfile, 'r') or
- return undef;
- local $/;
- my $pid = <$pidfh>;
- close $pidfh;
- ($pid) = $pid =~ /(\d+)/;
- if (defined $pid and kill(0,$pid)) {
- return $pid;
- }
- return 0;
- }
- else {
- return undef;
- }
-}
-
-
-=head1 QUIT
-
-These functions are exported with the :quit tag.
-
-=head2 quit
-
- quit()
-
-Exits the program by calling die.
-
-Usage of quit is deprecated; just call die instead.
-
-=cut
-
-sub quit {
- print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG;
- carp "quit() is deprecated; call die directly instead";
-}
-
-
-=head1 MISC
-
-These functions are exported with the :misc tag
-
-=head2 make_list
-
- LIST = make_list(@_);
-
-Turns a scalar or an arrayref into a list; expands a list of arrayrefs
-into a list.
-
-That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a
-b)],[qw(c d)] returns qw(a b c d);
-
-=cut
-
-sub make_list {
- return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_;
-}
-
-
-=head2 english_join
-
- print english_join(list => \@list);
- print english_join(\@list);
-
-Joins list properly to make an english phrase.
-
-=over
-
-=item normal -- how to separate most values; defaults to ', '
-
-=item last -- how to separate the last two values; defaults to ', and '
-
-=item only_two -- how to separate only two values; defaults to ' and '
-
-=item list -- ARRAYREF values to join; if the first argument is an
-ARRAYREF, it's assumed to be the list of values to join
-
-=back
-
-In cases where C is empty, returns ''; when there is only one
-element, returns that element.
-
-=cut
-
-sub english_join {
- if (ref $_[0] eq 'ARRAY') {
- return english_join(list=>$_[0]);
- }
- my %param = validate_with(params => \@_,
- spec => {normal => {type => SCALAR,
- default => ', ',
- },
- last => {type => SCALAR,
- default => ', and ',
- },
- only_two => {type => SCALAR,
- default => ' and ',
- },
- list => {type => ARRAYREF,
- },
- },
- );
- my @list = @{$param{list}};
- if (@list <= 1) {
- return @list?$list[0]:'';
- }
- elsif (@list == 2) {
- return join($param{only_two},@list);
- }
- my $ret = $param{last} . pop(@list);
- return join($param{normal},@list) . $ret;
-}
-
-
-=head2 globify_scalar
-
- my $handle = globify_scalar(\$foo);
-
-if $foo isn't already a glob or a globref, turn it into one using
-IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined.
-
-Will carp if given a scalar which isn't a scalarref or a glob (or
-globref), and return /dev/null. May return undef if IO::Scalar or
-IO::File fails. (Check $!)
-
-The scalar will fill with octets, not perl's internal encoding, so you
-must use decode_utf8() after on the scalar, and encode_utf8() on it
-before. This appears to be a bug in the underlying modules.
-
-=cut
-
-our $_NULL_HANDLE;
-
-sub globify_scalar {
- my ($scalar) = @_;
- my $handle;
- if (defined $scalar) {
- if (defined ref($scalar)) {
- if (ref($scalar) eq 'SCALAR' and
- not UNIVERSAL::isa($scalar,'GLOB')) {
- if (is_utf8(${$scalar})) {
- ${$scalar} = decode_utf8(${$scalar});
- carp(q(\$scalar must not be in perl's internal encoding));
- }
- open $handle, '>:scalar:utf8', $scalar;
- return $handle;
- }
- else {
- return $scalar;
- }
- }
- elsif (UNIVERSAL::isa(\$scalar,'GLOB')) {
- return $scalar;
- }
- else {
- carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle";
- }
- }
- if (not defined $_NULL_HANDLE or
- not $_NULL_HANDLE->opened()
- ) {
- $_NULL_HANDLE =
- IO::File->new('/dev/null','>:encoding(UTF-8)') or
- die "Unable to open /dev/null for writing: $!";
- }
- return $_NULL_HANDLE;
-}
-
-=head2 cleanup_eval_fail()
-
- print "Something failed with: ".cleanup_eval_fail($@);
-
-Does various bits of cleanup on the failure message from an eval (or
-any other die message)
-
-Takes at most two options; the first is the actual failure message
-(usually $@ and defaults to $@), the second is the debug level
-(defaults to $DEBUG).
-
-If debug is non-zero, the code at which the failure occured is output.
-
-=cut
-
-sub cleanup_eval_fail {
- my ($error,$debug) = @_;
- if (not defined $error or not @_) {
- $error = $@ // 'unknown reason';
- }
- if (@_ <= 1) {
- $debug = $DEBUG // 0;
- }
- $debug = 0 if not defined $debug;
-
- if ($debug > 0) {
- return $error;
- }
- # ditch the "at foo/bar/baz.pm line 5"
- $error =~ s/\sat\s\S+\sline\s\d+//;
- # ditch croak messages
- $error =~ s/^\t+.+\n?//mg;
- # ditch trailing multiple periods in case there was a cascade of
- # die messages.
- $error =~ s/\.+$/\./;
- return $error;
-}
-
-=head2 hash_slice
-
- hash_slice(%hash,qw(key1 key2 key3))
-
-For each key, returns matching values and keys of the hash if they exist
-
-=cut
-
-
-# NB: We use prototypes here SPECIFICALLY so that we can be passed a
-# hash without uselessly making a reference to first. DO NOT USE
-# PROTOTYPES USELESSLY ELSEWHERE.
-sub hash_slice(\%@) {
- my ($hashref,@keys) = @_;
- return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys;
-}
-
-
-1;
-
-__END__
diff --git a/Debbugs/Config.pm b/Debbugs/Config.pm
deleted file mode 100644
index 0d0abae..0000000
--- a/Debbugs/Config.pm
+++ /dev/null
@@ -1,1278 +0,0 @@
-# This module is part of debbugs, and is released
-# under the terms of the GPL version 2, or any later
-# version at your option.
-# See the file README and COPYING for more information.
-#
-# Copyright 2007 by Don Armstrong .
-
-package Debbugs::Config;
-
-=head1 NAME
-
-Debbugs::Config -- Configuration information for debbugs
-
-=head1 SYNOPSIS
-
- use Debbugs::Config;
-
-# to get the compatiblity interface
-
- use Debbugs::Config qw(:globals);
-
-=head1 DESCRIPTION
-
-This module provides configuration variables for all of debbugs.
-
-=head1 CONFIGURATION FILES
-
-The default configuration file location is /etc/debbugs/config; this
-configuration file location can be set by modifying the
-DEBBUGS_CONFIG_FILE env variable to point at a different location.
-
-=cut
-
-use warnings;
-use strict;
-use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT $USING_GLOBALS %config);
-use base qw(Exporter);
-
-BEGIN {
- # set the version for version checking
- $VERSION = 1.00;
- $DEBUG = 0 unless defined $DEBUG;
- $USING_GLOBALS = 0;
-
- @EXPORT = ();
- %EXPORT_TAGS = (globals => [qw($gEmailDomain $gListDomain $gWebHost $gWebHostBugDir),
- qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors),
- qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle),
- qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail),
- qw($gPackageTrackingDomain $gUsertagPackageDomain),
- qw($gSubmitList $gMaintList $gQuietList $gForwardList),
- qw($gDoneList $gRequestList $gSubmitterList $gControlList),
- qw($gStrongList),
- qw($gBugSubscriptionDomain),
- qw($gPackageVersionRe),
- qw($gSummaryList $gMirrorList $gMailer $gBug),
- qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity),
- qw($gShowSeverities $gBounceFroms $gConfigDir $gSpoolDir),
- qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile),
- qw($gMaintainerFileOverride $gPseudoMaintFile $gPseudoDescFile $gPackageSource),
- qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap),
- qw($gVersionTimeIndex),
- qw($gSimpleVersioning),
- qw($gCVETracker),
- qw($gSendmail @gSendmailArguments $gLibPath $gSpamScan @gExcludeFromControl),
- qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities),
- qw(%gTagsSingleLetter),
- qw(%gSearchEstraier),
- qw(%gDistributionAliases),
- qw(%gObsoleteSeverities),
- qw(@gPostProcessall @gRemovalDefaultDistributionTags @gRemovalDistributionTags @gRemovalArchitectures),
- qw(@gRemovalStrongSeverityDefaultDistributionTags),
- qw(@gAffectsDistributionTags),
- qw(@gDefaultArchitectures),
- qw($gMachineName),
- qw($gTemplateDir),
- qw($gDefaultPackage),
- qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb),
- qw($gDatabase),
- ],
- text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote),
- ],
- cgi => [qw($gLibravatarUri $gLibravatarCacheDir $gLibravatarUriOptions @gLibravatarBlacklist)],
- config => [qw(%config)],
- );
- @EXPORT_OK = ();
- Exporter::export_ok_tags(keys %EXPORT_TAGS);
- $EXPORT_TAGS{all} = [@EXPORT_OK];
- $ENV{HOME} = '' if not defined $ENV{HOME};
-}
-
-use Sys::Hostname;
-use File::Basename qw(dirname);
-use IO::File;
-use Safe;
-
-=head1 CONFIGURATION VARIABLES
-
-=head2 General Configuration
-
-=over
-
-=cut
-
-# read in the files;
-%config = ();
-# untaint $ENV{DEBBUGS_CONFIG_FILE} if it's owned by us
-# This enables us to test things that are -T.
-if (exists $ENV{DEBBUGS_CONFIG_FILE}) {
-# This causes all sorts of problems for mirrors of debbugs; disable
-# it.
-# if (${[stat($ENV{DEBBUGS_CONFIG_FILE})]}[4] == $<) {
- $ENV{DEBBUGS_CONFIG_FILE} =~ /(.+)/;
- $ENV{DEBBUGS_CONFIG_FILE} = $1;
-# }
-# else {
-# die "Environmental variable DEBBUGS_CONFIG_FILE set, and $ENV{DEBBUGS_CONFIG_FILE} is not owned by the user running this script.";
-# }
-}
-read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config');
-
-=item email_domain $gEmailDomain
-
-The email domain of the bts
-
-=cut
-
-set_default(\%config,'email_domain','bugs.something');
-
-=item list_domain $gListDomain
-
-The list domain of the bts, defaults to the email domain
-
-=cut
-
-set_default(\%config,'list_domain',$config{email_domain});
-
-=item web_host $gWebHost
-
-The web host of the bts; defaults to the email domain
-
-=cut
-
-set_default(\%config,'web_host',$config{email_domain});
-
-=item web_host_bug_dir $gWebHostDir
-
-The directory of the web host on which bugs are kept, defaults to C<''>
-
-=cut
-
-set_default(\%config,'web_host_bug_dir','');
-
-=item web_domain $gWebDomain
-
-Full path of the web domain where bugs are kept including the protocol (http://
-or https://). Defaults to the concatenation of 'http://', L and
-L
-
-=cut
-
-set_default(\%config,'web_domain','http://'.$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir});
-
-=item html_suffix $gHTMLSuffix
-
-Suffix of html pages, defaults to .html
-
-=cut
-
-set_default(\%config,'html_suffix','.html');
-
-=item cgi_domain $gCGIDomain
-
-Full path of the web domain where cgi scripts are kept. Defaults to
-the concatentation of L and cgi.
-
-=cut
-
-set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi');
-
-=item mirrors @gMirrors
-
-List of mirrors [What these mirrors are used for, no one knows.]
-
-=cut
-
-
-set_default(\%config,'mirrors',[]);
-
-=item package_pages $gPackagePages
-
-Domain where the package pages are kept; links should work in a
-package_pages/foopackage manner. Defaults to undef, which means that package
-links will not be made. Should be prefixed with the appropriate protocol
-(http/https).
-
-=cut
-
-
-set_default(\%config,'package_pages',undef);
-
-=item package_tracking_domain $gPackageTrackingDomain
-
-Domain where the package pages are kept; links should work in a
-package_tracking_domain/foopackage manner. Defaults to undef, which means that
-package links will not be made. Should be prefixed with the appropriate protocol
-(http or https).
-
-=cut
-
-set_default(\%config,'package_tracking_domain',undef);
-
-=item package_pages $gUsertagPackageDomain
-
-Domain where where usertags of packages belong; defaults to $gPackagePages
-
-=cut
-
-set_default(\%config,'usertag_package_domain',map {my $a = $_; defined $a?$a =~ s{https?://}{}:(); $a} $config{package_pages});
-
-
-=item subscription_domain $gSubscriptionDomain
-
-Domain where subscriptions to package lists happen
-
-=cut
-
-set_default(\%config,'subscription_domain',undef);
-
-
-=item cc_all_mails_to_addr $gCcAllMailsToAddr
-
-Address to Cc (well, Bcc) all e-mails to
-
-=cut
-
-set_default(\%config,'cc_all_mails_to_addr',undef);
-
-
-=item cve_tracker $gCVETracker
-
-URI to CVE security tracker; in bugreport.cgi, CVE-2001-0002 becomes
-linked to $config{cve_tracker}CVE-2001-002
-
-Default: https://security-tracker.debian.org/tracker/
-
-=cut
-
-set_default(\%config,'cve_tracker','https://security-tracker.debian.org/tracker/');
-
-
-=back
-
-=cut
-
-
-=head2 Project Identification
-
-=over
-
-=item project $gProject
-
-Name of the project
-
-Default: 'Something'
-
-=cut
-
-set_default(\%config,'project','Something');
-
-=item project_title $gProjectTitle
-
-Name of this install of Debbugs, defaults to "L Debbugs Install"
-
-Default: "$config{project} Debbugs Install"
-
-=cut
-
-set_default(\%config,'project_title',"$config{project} Debbugs Install");
-
-=item maintainer $gMaintainer
-
-Name of the maintainer of this debbugs install
-
-Default: 'Local DebBugs Owner's
-
-=cut
-
-set_default(\%config,'maintainer','Local DebBugs Owner');
-
-=item maintainer_webpage $gMaintainerWebpage
-
-Webpage of the maintainer of this install of debbugs
-
-Default: "$config{web_domain}/~owner"
-
-=cut
-
-set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner");
-
-=item maintainer_email $gMaintainerEmail
-
-Email address of the maintainer of this Debbugs install
-
-Default: 'root@'.$config{email_domain}
-
-=cut
-
-set_default(\%config,'maintainer_email','root@'.$config{email_domain});
-
-=item unknown_maintainer_email
-
-Email address where packages with an unknown maintainer will be sent
-
-Default: $config{maintainer_email}
-
-=cut
-
-set_default(\%config,'unknown_maintainer_email',$config{maintainer_email});
-
-=item machine_name
-
-The name of the machine that this instance of debbugs is running on
-(currently used for debbuging purposes and web page output.)
-
-Default: Sys::Hostname::hostname()
-
-=back
-
-=cut
-
-set_default(\%config,'machine_name',Sys::Hostname::hostname());
-
-=head2 BTS Mailing Lists
-
-
-=over
-
-=item submit_list
-
-=item maint_list
-
-=item forward_list
-
-=item done_list
-
-=item request_list
-
-=item submitter_list
-
-=item control_list
-
-=item summary_list
-
-=item mirror_list
-
-=item strong_list
-
-=cut
-
-set_default(\%config, 'submit_list', 'bug-submit-list');
-set_default(\%config, 'maint_list', 'bug-maint-list');
-set_default(\%config, 'quiet_list', 'bug-quiet-list');
-set_default(\%config, 'forward_list', 'bug-forward-list');
-set_default(\%config, 'done_list', 'bug-done-list');
-set_default(\%config, 'request_list', 'bug-request-list');
-set_default(\%config,'submitter_list','bug-submitter-list');
-set_default(\%config, 'control_list', 'bug-control-list');
-set_default(\%config, 'summary_list', 'bug-summary-list');
-set_default(\%config, 'mirror_list', 'bug-mirror-list');
-set_default(\%config, 'strong_list', 'bug-strong-list');
-
-=item bug_subscription_domain
-
-Domain of list for messages regarding a single bug; prefixed with
-bug=${bugnum}@ when bugs are actually sent out. Set to undef or '' to
-disable sending messages to the bug subscription list.
-
-Default: list_domain
-
-=back
-
-=cut
-
-set_default(\%config,'bug_subscription_domain',$config{list_domain});
-
-
-
-=head2 Misc Options
-
-=over
-
-=item mailer
-
-Name of the mailer to use
-
-Default: exim
-
-=cut
-
-set_default(\%config,'mailer','exim');
-
-
-=item bug
-
-Default: bug
-
-=item ubug
-
-Default: ucfirst($config{bug});
-
-=item bugs
-
-Default: bugs
-
-=item ubugs
-
-Default: ucfirst($config{ubugs});
-
-=cut
-
-set_default(\%config,'bug','bug');
-set_default(\%config,'ubug',ucfirst($config{bug}));
-set_default(\%config,'bugs','bugs');
-set_default(\%config,'ubugs',ucfirst($config{bugs}));
-
-=item remove_age
-
-Age at which bugs are archived/removed
-
-Default: 28
-
-=cut
-
-set_default(\%config,'remove_age',28);
-
-=item save_old_bugs
-
-Whether old bugs are saved or deleted
-
-Default: 1
-
-=cut
-
-set_default(\%config,'save_old_bugs',1);
-
-=item distribution_aliases
-
-Map of distribution aliases to the distribution name
-
-Default:
- {experimental => 'experimental',
- unstable => 'unstable',
- testing => 'testing',
- stable => 'stable',
- oldstable => 'oldstable',
- sid => 'unstable',
- lenny => 'testing',
- etch => 'stable',
- sarge => 'oldstable',
- }
-
-=cut
-
-set_default(\%config,'distribution_aliases',
- {experimental => 'experimental',
- unstable => 'unstable',
- testing => 'testing',
- stable => 'stable',
- oldstable => 'oldstable',
- sid => 'unstable',
- lenny => 'testing',
- etch => 'stable',
- sarge => 'oldstable',
- },
- );
-
-
-
-=item distributions
-
-List of valid distributions
-
-Default: The values of the distribution aliases map.
-
-=cut
-
-my %_distributions_default;
-@_distributions_default{values %{$config{distribution_aliases}}} = values %{$config{distribution_aliases}};
-set_default(\%config,'distributions',[keys %_distributions_default]);
-
-
-=item default_architectures
-
-List of default architectures to use when architecture(s) are not
-specified
-
-Default: i386 amd64 arm ppc sparc alpha
-
-=cut
-
-set_default(\%config,'default_architectures',
- [qw(i386 amd64 arm powerpc sparc alpha)]
- );
-
-=item affects_distribution_tags
-
-List of tags which restrict the buggy state to a set of distributions.
-
-The set of distributions that are buggy is the intersection of the set
-of distributions that would be buggy without reference to these tags
-and the set of these tags that are distributions which are set on a
-bug.
-
-Setting this to [] will remove this feature.
-
-Default: @{$config{distributions}}
-
-=cut
-
-set_default(\%config,'affects_distribution_tags',
- [@{$config{distributions}}],
- );
-
-=item removal_unremovable_tags
-
-Bugs which have these tags set cannot be archived
-
-Default: []
-
-=cut
-
-set_default(\%config,'removal_unremovable_tags',
- [],
- );
-
-=item removal_distribution_tags
-
-Tags which specifiy distributions to check
-
-Default: @{$config{distributions}}
-
-=cut
-
-set_default(\%config,'removal_distribution_tags',
- [@{$config{distributions}}]);
-
-=item removal_default_distribution_tags
-
-For removal/archival purposes, all bugs are assumed to have these tags
-set.
-
-Default: qw(experimental unstable testing);
-
-=cut
-
-set_default(\%config,'removal_default_distribution_tags',
- [qw(experimental unstable testing)]
- );
-
-=item removal_strong_severity_default_distribution_tags
-
-For removal/archival purposes, all bugs with strong severity are
-assumed to have these tags set.
-
-Default: qw(experimental unstable testing stable);
-
-=cut
-
-set_default(\%config,'removal_strong_severity_default_distribution_tags',
- [qw(experimental unstable testing stable)]
- );
-
-
-=item removal_architectures
-
-For removal/archival purposes, these architectures are consulted if
-there is more than one architecture applicable. If the bug is in a
-package not in any of these architectures, the architecture actually
-checked is undefined.
-
-Default: value of default_architectures
-
-=cut
-
-set_default(\%config,'removal_architectures',
- $config{default_architectures},
- );
-
-
-=item package_name_re
-
-The regex which will match a package name
-
-Default: '[a-z0-9][a-z0-9\.+-]+'
-
-=cut
-
-set_default(\%config,'package_name_re',
- '[a-z0-9][a-z0-9\.+-]+');
-
-=item package_version_re
-
-The regex which will match a package version
-
-Default: '[A-Za-z0-9:+\.-]+'
-
-=cut
-
-
-set_default(\%config,'package_version_re',
- '[A-Za-z0-9:+\.~-]+');
-
-
-=item default_package
-
-This is the name of the default package. If set, bugs assigned to
-packages without a maintainer and bugs missing a Package: psuedoheader
-will be assigned to this package instead.
-
-Defaults to unset, which is the traditional debbugs behavoir
-
-=cut
-
-set_default(\%config,'default_package',
- undef
- );
-
-
-=item control_internal_requester
-
-This address is used by Debbugs::Control as the request address which
-sent a control request for faked log messages.
-
-Default:"Debbugs Internal Request <$config{maintainer_email}>"
-
-=cut
-
-set_default(\%config,'control_internal_requester',
- "Debbugs Internal Request <$config{maintainer_email}>",
- );
-
-=item control_internal_request_addr
-
-This address is used by Debbugs::Control as the address to which a
-faked log message request was sent.
-
-Default: "internal_control\@$config{email_domain}";
-
-=cut
-
-set_default(\%config,'control_internal_request_addr',
- 'internal_control@'.$config{email_domain},
- );
-
-
-=item exclude_from_control
-
-Addresses which are not allowed to send messages to control
-
-=cut
-
-set_default(\%config,'exclude_from_control',[]);
-
-
-
-=item default_severity
-
-The default severity of bugs which have no severity set
-
-Default: normal
-
-=cut
-
-set_default(\%config,'default_severity','normal');
-
-=item severity_display
-
-A hashref of severities and the informative text which describes them.
-
-Default:
-
- {critical => "Critical $config{bugs}",
- grave => "Grave $config{bugs}",
- normal => "Normal $config{bugs}",
- wishlist => "Wishlist $config{bugs}",
- }
-
-=cut
-
-set_default(\%config,'severity_display',{critical => "Critical $config{bugs}",
- grave => "Grave $config{bugs}",
- serious => "Serious $config{bugs}",
- important=> "Important $config{bugs}",
- normal => "Normal $config{bugs}",
- minor => "Minor $config{bugs}",
- wishlist => "Wishlist $config{bugs}",
- });
-
-=item show_severities
-
-A scalar list of the severities to show
-
-Defaults to the concatenation of the keys of the severity_display
-hashlist with ', ' above.
-
-=cut
-
-set_default(\%config,'show_severities',join(', ',keys %{$config{severity_display}}));
-
-=item strong_severities
-
-An arrayref of the serious severities which shoud be emphasized
-
-Default: [qw(critical grave)]
-
-=cut
-
-set_default(\%config,'strong_severities',[qw(critical grave)]);
-
-=item severity_list
-
-An arrayref of a list of the severities
-
-Defaults to the keys of the severity display hashref
-
-=cut
-
-set_default(\%config,'severity_list',[keys %{$config{severity_display}}]);
-
-=item obsolete_severities
-
-A hashref of obsolete severities with the replacing severity
-
-Default: {}
-
-=cut
-
-set_default(\%config,'obsolete_severities',{});
-
-=item tags
-
-An arrayref of the tags used
-
-Default: [qw(patch wontfix moreinfo unreproducible fixed)] and also
-includes the distributions.
-
-=cut
-
-set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed),
- @{$config{distributions}}
- ]);
-
-set_default(\%config,'tags_single_letter',
- {patch => '+',
- wontfix => '',
- moreinfo => 'M',
- unreproducible => 'R',
- fixed => 'F',
- }
- );
-
-set_default(\%config,'bounce_froms','^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|'.
- '^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|'.
- '^mail.*agent|^tcpmail|^bitmail|^mailman');
-
-set_default(\%config,'config_dir',dirname(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config'));
-set_default(\%config,'spool_dir','/var/lib/debbugs/spool');
-
-=item usertag_dir
-
-Directory which contains the usertags
-
-Default: $config{spool_dir}/user
-
-=cut
-
-set_default(\%config,'usertag_dir',$config{spool_dir}.'/user');
-set_default(\%config,'incoming_dir','incoming');
-
-=item web_dir $gWebDir
-
-Directory where base html files are kept. Should normally be the same
-as the web server's document root.
-
-Default: /var/lib/debbugs/www
-
-=cut
-
-set_default(\%config,'web_dir','/var/lib/debbugs/www');
-set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt');
-set_default(\%config,'lib_path','/usr/lib/debbugs');
-
-
-=item template_dir
-
-directory of templates; defaults to /usr/share/debbugs/templates.
-
-=cut
-
-set_default(\%config,'template_dir','/usr/share/debbugs/templates');
-
-
-set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers');
-set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override');
-set_default(\%config,'source_maintainer_file',$config{config_dir}.'/Source_maintainers');
-set_default(\%config,'source_maintainer_file_override',undef);
-set_default(\%config,'pseudo_maint_file',$config{config_dir}.'/pseudo-packages.maintainers');
-set_default(\%config,'pseudo_desc_file',$config{config_dir}.'/pseudo-packages.description');
-set_default(\%config,'package_source',$config{config_dir}.'/indices/sources');
-
-
-=item simple_versioning
-
-If true this causes debbugs to ignore version information and just
-look at whether a bug is done or not done. Primarily of interest for
-debbugs installs which don't track versions. defaults to false.
-
-=cut
-
-set_default(\%config,'simple_versioning',0);
-
-
-=item version_packages_dir
-
-Location where the version package information is kept; defaults to
-spool_dir/../versions/pkg
-
-=cut
-
-set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg');
-
-=item version_time_index
-
-Location of the version/time index file. Defaults to
-spool_dir/../versions/idx/versions_time.idx if spool_dir/../versions
-exists; otherwise defaults to undef.
-
-=cut
-
-
-set_default(\%config,'version_time_index', -d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions_time.idx' : undef);
-
-=item version_index
-
-Location of the version index file. Defaults to
-spool_dir/../versions/indices/versions.idx if spool_dir/../versions
-exists; otherwise defaults to undef.
-
-=cut
-
-set_default(\%config,'version_index',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions.idx' : undef);
-
-=item binary_source_map
-
-Location of the binary -> source map. Defaults to
-spool_dir/../versions/indices/bin2src.idx if spool_dir/../versions
-exists; otherwise defaults to undef.
-
-=cut
-
-set_default(\%config,'binary_source_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/binsrc.idx' : undef);
-
-=item source_binary_map
-
-Location of the source -> binary map. Defaults to
-spool_dir/../versions/indices/src2bin.idx if spool_dir/../versions
-exists; otherwise defaults to undef.
-
-=cut
-
-set_default(\%config,'source_binary_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/srcbin.idx' : undef);
-
-
-
-set_default(\%config,'post_processall',[]);
-
-=item sendmail
-
-Sets the sendmail binary to execute; defaults to /usr/lib/sendmail
-
-=cut
-
-set_default(\%config,'sendmail','/usr/lib/sendmail');
-
-=item sendmail_arguments
-
-Default arguments to pass to sendmail. Defaults to C.
-
-=cut
-
-set_default(\%config,'sendmail_arguments',[qw(-oem -oi)]);
-
-=item envelope_from
-
-Envelope from to use for sent messages. If not set, whatever sendmail picks is
-used.
-
-=cut
-
-set_default(\%config,'envelope_from',undef);
-
-=item spam_scan
-
-Whether or not spamscan is being used; defaults to 0 (not being used
-
-=cut
-
-set_default(\%config,'spam_scan',0);
-
-=item spam_crossassassin_db
-
-Location of the crosassassin database, defaults to
-spool_dir/../CrossAssassinDb
-
-=cut
-
-set_default(\%config,'spam_crossassassin_db',$config{spool_dir}.'/../CrossAssassinDb');
-
-=item spam_max_cross
-
-Maximum number of cross-posted messages
-
-=cut
-
-set_default(\%config,'spam_max_cross',6);
-
-
-=item spam_spams_per_thread
-
-Number of spams for each thread (on average). Defaults to 200
-
-=cut
-
-set_default(\%config,'spam_spams_per_thread',200);
-
-=item spam_max_threads
-
-Maximum number of threads to start. Defaults to 20
-
-=cut
-
-set_default(\%config,'spam_max_threads',20);
-
-=item spam_keep_running
-
-Maximum number of seconds to run without restarting. Defaults to 3600.
-
-=cut
-
-set_default(\%config,'spam_keep_running',3600);
-
-=item spam_mailbox
-
-Location to store spam messages; is run through strftime to allow for
-%d,%m,%Y, et al. Defaults to 'spool_dir/../mail/spam/assassinated.%Y-%m-%d'
-
-=cut
-
-set_default(\%config,'spam_mailbox',$config{spool_dir}.'/../mail/spam/assassinated.%Y-%m-%d');
-
-=item spam_crossassassin_mailbox
-
-Location to store crossassassinated messages; is run through strftime
-to allow for %d,%m,%Y, et al. Defaults to
-'spool_dir/../mail/spam/crossassassinated.%Y-%m-%d'
-
-=cut
-
-set_default(\%config,'spam_crossassassin_mailbox',$config{spool_dir}.'/../mail/spam/crossassassinated.%Y-%m-%d');
-
-=item spam_local_tests_only
-
-Whether only local tests are run, defaults to 0
-
-=cut
-
-set_default(\%config,'spam_local_tests_only',0);
-
-=item spam_user_prefs
-
-User preferences for spamassassin, defaults to $ENV{HOME}/.spamassassin/user_prefs
-
-=cut
-
-set_default(\%config,'spam_user_prefs',"$ENV{HOME}/.spamassassin/user_prefs");
-
-=item spam_rules_dir
-
-Site rules directory for spamassassin, defaults to
-'/usr/share/spamassassin'
-
-=cut
-
-set_default(\%config,'spam_rules_dir','/usr/share/spamassassin');
-
-=back
-
-=head2 CGI Options
-
-=over
-
-=item libravatar_uri $gLibravatarUri
-
-URI to a libravatar configuration. If empty or undefined, libravatar
-support will be disabled. Defaults to
-libravatar.cgi, our internal federated libravatar system.
-
-=cut
-
-set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email=');
-
-=item libravatar_uri_options $gLibravatarUriOptions
-
-Options to append to the md5_hex of the e-mail. This sets the default
-avatar used when an avatar isn't available. Currently defaults to
-'?d=retro', which causes a bitmap-looking avatar to be displayed for
-unknown e-mails.
-
-Other options which make sense include ?d=404, ?d=wavatar, etc. See
-the API of libravatar for details.
-
-=cut
-
-set_default(\%config,'libravatar_uri_options','');
-
-=item libravatar_default_image
-
-Default image to serve for libravatar if there is no avatar for an
-e-mail address. By default, this is a 1x1 png. [This will also be the
-image served if someone specifies avatar=no.]
-
-Default: $config{web_dir}/1x1.png
-
-=cut
-
-set_default(\%config,'libravatar_default_image',$config{web_dir}.'/1x1.png');
-
-=item libravatar_cache_dir
-
-Directory where cached libravatar images are stored
-
-Default: $config{web_dir}/libravatar/
-
-=cut
-
-set_default(\%config,'libravatar_cache_dir',$config{web_dir}.'/libravatar/');
-
-=item libravatar_blacklist
-
-Array of regular expressions to match against emails, domains, or
-images to only show the default image
-
-Default: empty array
-
-=cut
-
-set_default(\%config,'libravatar_blacklist',[]);
-
-=back
-
-=head2 Database
-
-=over
-
-=item database
-
-Name of debbugs PostgreSQL database service. If you wish to not use a service
-file, provide a full DBD::Pg compliant data-source, for example:
-C<"dbi:Pg:dbname=dbname">
-
-=back
-
-=cut
-
-set_default(\%config,'database',undef);
-
-=head2 Text Fields
-
-The following are the only text fields in general use in the scripts;
-a few additional text fields are defined in text.in, but are only used
-in db2html and a few other specialty scripts.
-
-Earlier versions of debbugs defined these values in /etc/debbugs/text,
-but now they are required to be in the configuration file. [Eventually
-the longer ones will move out into a fully fledged template system.]
-
-=cut
-
-=over
-
-=item bad_email_prefix
-
-This prefixes the text of all lines in a bad e-mail message ack.
-
-=cut
-
-set_default(\%config,'bad_email_prefix','');
-
-
-=item text_instructions
-
-This gives more information about bad e-mails to receive.in
-
-=cut
-
-set_default(\%config,'text_instructions',$config{bad_email_prefix});
-
-=item html_tail
-
-This shows up at the end of (most) html pages
-
-In many pages this has been replaced by the html/tail template.
-
-=cut
-
-set_default(\%config,'html_tail',<$config{maintainer} <$config{maintainer_email}>.
- Last modified:
-
- SUBSTITUTE_DTIME
-
-