--- /dev/null
--- /dev/null
- for limited regular expressions.
++
++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 vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
++use base qw(Exporter);
++
++BEGIN{
++ $VERSION = 1.00;
++ $DEBUG = 0 unless defined $DEBUG;
++
++ @EXPORT = ();
++ %EXPORT_TAGS = ();
++ @EXPORT_OK = (qw(get_bugs));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++use Debbugs::Config qw(:config);
++use Params::Validate qw(validate_with :types);
++use IO::File;
++use Debbugs::Status;
++use Debbugs::Packages qw(getsrcpkgs);
+++use Fcntl qw(O_RDONLY);
+++use MLDBM qw(DB_File Storable);
++
++=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 my $routine (qw(Debbugs::Bugs::get_bugs_flatfile)) {
+++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 maintenc -- encoded 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 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.
++
++=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
++
++sub get_bugs{
++ my %param = validate_with(params => \@_,
++ spec => {package => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ src => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ maint => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ maintenc => {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,
++ },
+++ function => {type => CODEREF,
+++ optional => 1,
+++ },
++ bugs => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ archive => {type => BOOLEAN,
++ default => 0,
++ },
++ usertags => {type => HASHREF,
++ optional => 1,
++ },
++ },
++ );
++
++ # Normalize options
++ my %options = %param;
++ my @bugs;
++ # A configuration option will set an array that we'll use here instead.
+++ for my $routine (qw(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 get_bugs_by_idx
+++
+++This routine uses the by-$index.idx indicies to try to speed up
+++searches.
+++
+++
+++=cut
+++
+++sub get_bugs_by_idx{
+++ my %param = validate_with(params => \@_,
+++ spec => {package => {type => SCALAR|ARRAYREF,
+++ optional => 1,
+++ },
+++ submitter => {type => SCALAR|ARRAYREF,
+++ optional => 1,
+++ },
+++ severity => {type => SCALAR|ARRAYREF,
+++ optional => 1,
+++ },
+++ tag => {type => SCALAR|ARRAYREF,
+++ optional => 1,
+++ },
+++ archive => {type => BOOLEAN,
+++ default => 0,
+++ },
+++ },
+++ );
+++ my %bugs = ();
+++ my $keys = keys %param - 1;
+++ die "Need at least 1 key to search by" unless $keys;
+++ my $arc = $params{archive} ? '-arc':''
+++ my %idx;
+++ for my $key (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 $!";
+++ for my $search (__make_list($param{$key})) {
+++ next unless defined $idx{$search};
+++ for my $bug (keys %{$idx{$search}}) {
+++ # increment the number of searches that this bug matched
+++ $bugs{$bug}++;
+++ }
+++ }
+++ untie %idx or die 'Unable to untie %idx';
+++ }
+++ # Throw out results that do not match all of the search specifications
+++ return map {$keys == $bugs{$bug}?($bug):()} keys %bugs;
+++}
+++
+++
+++=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
+++
++sub get_bugs_flatfile{
++ my %param = validate_with(params => \@_,
++ spec => {package => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ src => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ maint => {type => SCALAR|ARRAYREF,
++ optional => 1,
++ },
++ maintenc => {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,
++ },
++# not yet supported
++# owner => {type => SCALAR|ARRAYREF,
++# optional => 1,
++# },
++# dist => {type => SCALAR|ARRAYREF,
++# optional => 1,
++# },
++ archive => {type => BOOLEAN,
++ default => 1,
++ },
++ usertags => {type => HASHREF,
++ optional => 1,
++ },
+++ function => {type => CODEREF,
+++ optional => 1,
+++ },
++ },
++ );
++ my $flatfile;
++ if ($param{archive}) {
++ $flatfile = new IO::File "$debbugs::gSpoolDir/index.archive", 'r'
++ or die "Unable to open $debbugs::gSpoolDir/index.archive for reading: $!";
++ }
++ else {
++ $flatfile = new IO::File "$debbugs::gSpoolDir/index.db", 'r'
++ or die "Unable to open $debbugs::gSpoolDir/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{map {@{$_}}
++ @{$param{usertags}}{__make_list($param{tag})}
++ } = (1) x @{$param{usertags}}{__make_list($param{tag})}
++ }
++ my @bugs;
++ while (<$flatfile>) {
++ next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
++ my ($pkg,$bug,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
++ next if exists $param{bug} and not grep {$bug == $_} __make_list($param{bugs});
++ if (exists $param{pkg}) {
++ my @packages = splitpackages($pkg);
++ next unless grep { my $pkg_list = $_;
++ grep {$pkg_list eq $_} __make_list($param{pkg})
++ } @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 {$_->address}
++ map {lc(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],
+++ next unless
+++ $param{function}->(pkg => $package,
+++ bug => $bug,
+++ status => $status,
+++ submitter => $submitter,
+++ severity => $severity,
+++ tags => \@bug_tags,
+++ );
+++ }
++ push @bugs, $bug;
++ }
++ return @bugs;
++}
++
++
++# This private subroutine takes a scalar and turns it
++# into a list; transforming arrayrefs into their contents
++# along the way.
++sub __make_list{
++ return map {ref($_) eq 'ARRAY'?@{$_}:$_} @_;
++}
++
++1;
++
++__END__
--- /dev/null
--- /dev/null
- %EXPORT_TAGS = (url => [qw(bug_url)],
- html => [qw(html_escape)],
++
++package Debbugs::CGI;
++
++=head1 NAME
++
++Debbugs::CGI -- General routines for the cgi scripts
++
++=head1 SYNOPSIS
++
++use Debbugs::CGI qw(:url :html);
++
++html_escape(bug_url($ref,mbox=>'yes',mboxstatus=>'yes'));
++
++=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 base qw(Exporter);
++use Debbugs::URI;
++use HTML::Entities;
++use Debbugs::Common qw();
+++use Params::Validate qw(validate_with :types);
+++use Debbugs::Config qw(:config);
+++use Mail::Address;
+++use POSIX qw(ceil);
+++
+++my %URL_PARAMS = ();
+++
++
++BEGIN{
++ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
++ $DEBUG = 0 unless defined $DEBUG;
++
++ @EXPORT = ();
- Exporter::export_ok_tags(qw(url html));
+++ %EXPORT_TAGS = (url => [qw(bug_url bug_links bug_linklist maybelink),
+++ qw(set_url_params pkg_url version_url),
+++ ],
+++ html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
+++ qw(maybelink htmlize_addresslinks),
+++ ],
+++ util => [qw(getparsedaddrs)]
++ #status => [qw(getbugstatus)],
++ );
++ @EXPORT_OK = ();
- my %params = @_;
+++ Exporter::export_ok_tags(qw(url html util));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++
++
+++=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 bug_url
++
++ bug_url($ref,mbox=>'yes',mboxstat=>'yes');
++
++Constructs urls which point to a specific
++
+++XXX use Params::Validate
+++
++=cut
++
++sub bug_url{
++ my $ref = shift;
+++ my %params;
+++ if (@_ % 2) {
+++ shift;
+++ %params = (%URL_PARAMS,@_);
+++ }
+++ else {
+++ %params = @_;
+++ }
++ my $url = Debbugs::URI->new('bugreport.cgi?');
++ $url->query_form(bug=>$ref,%params);
++ return $url->as_string;
++}
++
+++sub pkg_url{
+++ my %params;
+++ if (@_ % 2) {
+++ shift;
+++ %params = (%URL_PARAMS,@_);
+++ }
+++ else {
+++ %params = @_;
+++ }
+++ my $url = Debbugs::URI->new('pkgreport.cgi?');
+++ $url->query_form(%params);
+++ return $url->as_string;
+++}
+++
+++=head2 version_url
+++
+++ version_url($package,$found,$fixed)
+++
+++Creates a link to the version cgi script
+++
+++=cut
+++
+++sub version_url{
+++ my ($package,$found,$fixed) = @_;
+++ my $url = Debbugs::URI->new('version.cgi?');
+++ $url->query_form(package => $package,
+++ found => $found,
+++ fixed => $fixed,
+++ );
+++ 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)
++}
++
++my %common_bugusertags;
++
++# =head2 get_bug_status
++#
++# my $status = getbugstatus($bug_num)
++#
++# my $status = getbugstatus($bug_num,$bug_index)
++#
++#
++# =cut
++#
++# sub get_bug_status {
++# my ($bugnum,$bugidx) = @_;
++#
++# my %status;
++#
++# if (defined $bugidx and exists $bugidx->{$bugnum}) {
++# %status = %{ $bugidx->{$bugnum} };
++# $status{pending} = $status{ status };
++# $status{id} = $bugnum;
++# return \%status;
++# }
++#
++# my $location = getbuglocation($bugnum, 'summary');
++# return {} if not length $location;
++# %status = %{ readbug( $bugnum, $location ) };
++# $status{id} = $bugnum;
++#
++#
++# if (defined $common_bugusertags{$bugnum}) {
++# $status{keywords} = "" unless defined $status{keywords};
++# $status{keywords} .= " " unless $status{keywords} eq "";
++# $status{keywords} .= join(" ", @{$common_bugusertags{$bugnum}});
++# }
++# $status{tags} = $status{keywords};
++# my %tags = map { $_ => 1 } split ' ', $status{tags};
++#
++# $status{"package"} =~ s/\s*$//;
++# $status{"package"} = 'unknown' if ($status{"package"} eq '');
++# $status{"severity"} = 'normal' if ($status{"severity"} eq '');
++#
++# $status{"pending"} = 'pending';
++# $status{"pending"} = 'forwarded' if (length($status{"forwarded"}));
++# $status{"pending"} = 'pending-fixed' if ($tags{pending});
++# $status{"pending"} = 'fixed' if ($tags{fixed});
++#
++# my @versions;
++# if (defined $common_version) {
++# @versions = ($common_version);
++# } elsif (defined $common_dist) {
++# @versions = getversions($status{package}, $common_dist, $common_arch);
++# }
++#
++# # TODO: This should probably be handled further out for efficiency and
++# # for more ease of distinguishing between pkg= and src= queries.
++# my @sourceversions = makesourceversions($status{package}, $common_arch,
++# @versions);
++#
++# if (@sourceversions) {
++# # Resolve bugginess states (we might be looking at multiple
++# # architectures, say). Found wins, then fixed, then absent.
++# my $maxbuggy = 'absent';
++# for my $version (@sourceversions) {
++# my $buggy = buggyversion($bugnum, $version, \%status);
++# if ($buggy eq 'found') {
++# $maxbuggy = 'found';
++# last;
++# } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
++# $maxbuggy = 'fixed';
++# }
++# }
++# if ($maxbuggy eq 'absent') {
++# $status{"pending"} = 'absent';
++# } elsif ($maxbuggy eq 'fixed') {
++# $status{"pending"} = 'done';
++# }
++# }
++#
++# if (length($status{done}) and
++# (not @sourceversions or not @{$status{fixed_versions}})) {
++# $status{"pending"} = 'done';
++# }
++#
++# return \%status;
++# }
++
++
+++# htmlize_bugs(bugs=>[@bugs]);
+++=head2 htmlize_bugs
+++
+++ htmlize_bugs({bug=>1,status=>\%status,extravars=>\%extra},{bug=>...}});
+++
+++Turns a list of bugs into an html snippit of the bugs.
+++
+++=cut
+++
+++sub htmlize_bugs{
+++ my @bugs = @_;
+++ my @html;
+++
+++ for my $bug (@bugs) {
+++ my $html = sprintf "<li><a href=\"%s\">#%d: %s</a>\n<br>",
+++ bug_url($bug->{bug}), $bug->{bug}, html_escape($bug->{status}{subject});
+++ $html .= htmlize_bugstatus($bug->{status}) . "\n";
+++ }
+++ return @html;
+++}
+++
+++
+++sub htmlize_bugstatus {
+++ my %status = %{$_[0]};
+++
+++ my $result = "";
+++
+++ my $showseverity;
+++ if ($status{severity} eq $config{default_severity}) {
+++ $showseverity = '';
+++ } elsif (isstrongseverity($status{severity})) {
+++ $showseverity = "Severity: <em class=\"severity\">$status{severity}</em>;\n";
+++ } else {
+++ $showseverity = "Severity: <em>$status{severity}</em>;\n";
+++ }
+++
+++ $result .= htmlize_packagelinks($status{"package"}, 1);
+++
+++ my $showversions = '';
+++ if (@{$status{found_versions}}) {
+++ my @found = @{$status{found_versions}};
+++ local $_;
+++ s{/}{ } foreach @found;
+++ $showversions .= join ', ', map html_escape($_), @found;
+++ }
+++ if (@{$status{fixed_versions}}) {
+++ $showversions .= '; ' if length $showversions;
+++ $showversions .= '<strong>fixed</strong>: ';
+++ my @fixed = @{$status{fixed_versions}};
+++ $showversions .= join ', ', map {s#/##; html_escape($_)} @fixed;
+++ }
+++ $result .= " ($showversions)" if length $showversions;
+++ $result .= ";\n";
+++
+++ $result .= $showseverity;
+++ $result .= htmlize_addresslinks("Reported by: ", \&submitterurl,
+++ $status{originator});
+++ $result .= ";\nOwned by: " . html_escape($status{owner})
+++ if length $status{owner};
+++ $result .= ";\nTags: <strong>"
+++ . html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
+++ . "</strong>"
+++ if (length($status{tags}));
+++
+++ $result .= ";\nMerged with ".
+++ bug_linklist(', ',
+++ 'submitter',
+++ split(/ /,$status{mergedwith}))
+++ if length $status{mergedwith};
+++ $result .= ";\nBlocked by ".
+++ bug_linklist(", ",
+++ 'submitter',
+++ split(/ /,$status{blockedby}))
+++ if length $status{blockedby};
+++ $result .= ";\nBlocks ".
+++ bug_linklist(", ",
+++ 'submitter',
+++ split(/ /,$status{blocks})
+++ )
+++ if length $status{blocks};
+++
+++ my $days = 0;
+++ if (length($status{done})) {
+++ $result .= "<br><strong>Done:</strong> " . html_escape($status{done});
+++ $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
+++ if ($days >= 0) {
+++ $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</strong>";
+++ } else {
+++ $result .= ";\n<strong>Archived</strong>";
+++ }
+++ }
+++ else {
+++ if (length($status{forwarded})) {
+++ $result .= ";\n<strong>Forwarded</strong> to "
+++ . maybelink($status{forwarded});
+++ }
+++ my $daysold = int((time - $status{date}) / 86400); # seconds to days
+++ if ($daysold >= 7) {
+++ my $font = "";
+++ my $efont = "";
+++ $font = "em" if ($daysold > 30);
+++ $font = "strong" if ($daysold > 60);
+++ $efont = "</$font>" if ($font);
+++ $font = "<$font>" if ($font);
+++
+++ my $yearsold = int($daysold / 365);
+++ $daysold -= $yearsold * 365;
+++
+++ $result .= ";\n $font";
+++ my @age;
+++ push @age, "1 year" if ($yearsold == 1);
+++ push @age, "$yearsold years" if ($yearsold > 1);
+++ push @age, "1 day" if ($daysold == 1);
+++ push @age, "$daysold days" if ($daysold > 1);
+++ $result .= join(" and ", @age);
+++ $result .= " old$efont";
+++ }
+++ }
+++
+++ $result .= ".";
+++
+++ return $result;
+++}
+++
+++# Split a package string from the status file into a list of package names.
+++sub splitpackages {
+++ my $pkgs = shift;
+++ return unless defined $pkgs;
+++ return map lc, split /[ \t?,()]+/, $pkgs;
+++}
+++
+++
+++=head2 htmlize_packagelinks
+++
+++ htmlize_packagelinks
+++
+++Given a scalar containing a list of packages separated by something
+++that L<Debbugs::CGI/splitpackages> can separate, returns a
+++formatted set of links to packages.
+++
+++=cut
+++
+++sub htmlize_packagelinks {
+++ my ($pkgs,$strong) = @_;
+++ return unless defined $pkgs and $pkgs ne '';
+++ my @pkglist = splitpackages($pkgs);
+++
+++ $strong = 0;
+++ my $openstrong = $strong ? '<strong>' : '';
+++ my $closestrong = $strong ? '</strong>' : '';
+++
+++ return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
+++ join(', ',
+++ map {
+++ '<a class="submitter" href="' . pkg_url(pkg=>$_||'') . '">' .
+++ $openstrong . html_escape($_) . $closestrong . '</a>'
+++ } @pkglist
+++ );
+++}
+++
+++
+++=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) = @_;
+++ $join = ' ' if not defined $join;
+++ my @return;
+++ my @segments;
+++ if (defined $regex) {
+++ @segments = split $regex, $links;
+++ }
+++ else {
+++ @segments = ($links);
+++ }
+++ for my $in (@segments) {
+++ if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
+++ push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
+++ } else {
+++ push @return, html_escape($in);
+++ }
+++ }
+++ return @return?join($join,@return):'';
+++}
+++
+++
+++=head2 htmlize_addresslinks
+++
+++ htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
+++
+++
+++Generate a comma-separated list of HTML links to each address given in
+++$addresses, which should be a comma-separated list of RFC822
+++addresses. $urlfunc should be a reference to a function like mainturl
+++or submitterurl which returns the URL for each individual address.
+++
+++
+++=cut
+++
+++sub htmlize_addresslinks {
+++ my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
+++ $class = defined $class?qq(class="$class" ):'';
+++ if (defined $addresses and $addresses ne '') {
+++ my @addrs = getparsedaddrs($addresses);
+++ my $prefix = (ref $prefixfunc) ?
+++ $prefixfunc->(scalar @addrs):$prefixfunc;
+++ return $prefix .
+++ join ', ', map
+++ { sprintf qq(<a ${class}).
+++ 'href="%s">%s</a>',
+++ $urlfunc->($_->address),
+++ html_escape($_->format) ||
+++ '(unknown)'
+++ } @addrs;
+++ }
+++ else {
+++ my $prefix = (ref $prefixfunc) ?
+++ $prefixfunc->(1) : $prefixfunc;
+++ return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
+++ $prefix, $urlfunc->('');
+++ }
+++}
+++
+++
+++
+++my %_parsedaddrs;
+++sub getparsedaddrs {
+++ my $addr = shift;
+++ return () unless defined $addr;
+++ return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
+++ @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
+++ return @{$_parsedaddrs{$addr}};
+++}
+++
+++
+++=head2 bug_links
+++
+++ bug_links($one_bug);
+++ bug_links($starting_bug,$stoping_bugs,);
+++
+++Creates a set of links to bugs, starting with bug number
+++$starting_bug, and finishing with $stoping_bug; if only one bug is
+++passed, makes a link to only a single bug.
+++
+++The content of the link is the bug number.
+++
+++XXX Use L<Params::Validate>; we want to be able to support query
+++arguments here too.
+++
+++=cut
+++
+++sub bug_links{
+++ my ($start,$stop,$query_arguments) = @_;
+++ $stop = $stop || $start;
+++ $query_arguments ||= '';
+++ my @output;
+++ for my $bug ($start..$stop) {
+++ push @output,'<a href="'.bug_url($bug,'').qq(">$bug</a>);
+++ }
+++ return join(', ',@output);
+++}
+++
+++=head2 bug_linklist
+++
+++ bug_linklist($separator,$class,@bugs)
+++
+++Creates a set of links to C<@bugs> separated by C<$separator> with
+++link class C<$class>.
+++
+++XXX Use L<Params::Validate>; we want to be able to support query
+++arguments here too; we should be able to combine bug_links and this
+++function into one. [Hell, bug_url should be one function with this one
+++too.]
+++
+++=cut
+++
+++
+++sub bug_linklist{
+++ my ($sep,$class,@bugs) = @_;
+++ if (length $class) {
+++ $class = qq(class="$class" );
+++ }
+++ return join($sep,map{qq(<a ${class}href=").
+++ bug_url($_).qq(">#$_</a>)
+++ } @bugs);
+++}
+++
+++
+++
++
++1;
++
++
++__END__
++
++
++
++
++
++
--package Debbugs::Common;
++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;
- Exporter::export_ok_tags(qw(read util));
++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
++use base qw(Exporter);
++
++BEGIN{
++ $VERSION = 1.00;
++ $DEBUG = 0 unless defined $DEBUG;
++
++ @EXPORT = ();
++ %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname),
++ qw(appendfile),
++ ],
++ quit => [qw(quit)],
++ lock => [qw(filelock unfilelock)],
++ );
++ @EXPORT_OK = ();
+++ Exporter::export_ok_tags(qw(lock quit util));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++#use Debbugs::Config qw(:globals);
++use Debbugs::Config qw(:config);
++use IO::File;
++use Debbugs::MIME qw(decode_rfc1522);
++
++use Fcntl qw(:flock);
++
++=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');
++ }
++ return undef if not defined $location;
++ my $dir = getlocationpath($location);
++ return undef if not defined $dir;
++ if ($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";
++ }
++}
--BEGIN {
-- use Exporter ();
-- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-- # set the version for version checking
-- $VERSION = 1.00;
++=head2 get_hashname
-- @ISA = qw(Exporter);
-- @EXPORT = qw(&fail &NameToPathHash &sani &quit);
-- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
++ get_hashname
-- # your exported package globals go here,
-- # as well as any optionally exported functions
-- @EXPORT_OK = qw();
++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 appendfile
++
++ appendfile($file,'data','to','append');
++
++Opens a file for appending and writes data to it.
++
++=cut
++
++sub appendfile {
++ my $file = shift;
++ if (!open(AP,">>$file")) {
++ print DEBUG "failed open log<\n";
++ print DEBUG "failed open log err $!<\n";
++ &quit("opening $file (appendfile): $!");
++ }
++ print(AP @_) || &quit("writing $file (appendfile): $!");
++ close(AP) || &quit("closing $file (appendfile): $!");
}
--use vars @EXPORT_OK;
--use Debbugs::Config qw(%Globals);
--use FileHandle;
++=head1 LOCK
++
++These functions are exported with the :lock tag
++
++=head2 filelock
++
++ filelock
++
++FLOCKs the passed file. Use unfilelock to unlock it.
++
++=cut
++
++my @filelocks;
+ my @cleanups;
--my $DEBUG = new FileHandle;
--
--sub fail
--{
-- print "$_[0]\n";
-- exit 1;
--}
--sub NameToPathHash
--{
--# 12345 -> 5/4/3/12345
--# 12 -> s/2/1/12
-- my $name = $_[0];
-- my $tmp = $name;
-- $name =~ /^.*?(.)(.)(.)$/ ;
-- if(!defined($1)) {
-- $name =~ /^(.*?)(.)(.)$/ ;
-- $tmp = "$1$2$3"."s";
++
++sub filelock {
++ # NB - NOT COMPATIBLE WITH `with-lock'
++ my ($lockfile) = @_;
++ my ($count,$errors) = @_;
++ $count= 10; $errors= '';
++ for (;;) {
++ my $fh = eval {
++ my $fh = new IO::File $lockfile,'w'
++ or die "Unable to open $lockfile for writing: $!";
++ flock($fh,LOCK_EX|LOCK_NB)
++ or die "Unable to lock $lockfile $!";
++ return $fh;
++ };
++ if ($@) {
++ $errors .= $@;
++ }
++ if ($fh) {
++ push @filelocks, {fh => $fh, file => $lockfile};
++ last;
++ }
++ if (--$count <=0) {
++ $errors =~ s/\n+$//;
++ &quit("failed to get lock on $lockfile -- $errors");
++ }
++ sleep 10;
}
-- $tmp =~ /^.*?(.)(.)(.)$/ ;
-- return "$3/$2/$1/$name";
++ push(@cleanups,\&unfilelock);
}
--sub DEBUG
--{
-- print $DEBUG $_;
++
++=head2 unfilelock
++
++ unfilelock()
++
++Unlocks the file most recently locked.
++
++Note that it is not currently possible to unlock a specific file
++locked with filelock.
++
++=cut
++
++sub unfilelock {
++ if (@filelocks == 0) {
++ warn "unfilelock called with no active filelocks!\n";
++ return;
++ }
++ my %fl = %{pop(@filelocks)};
++ pop(@cleanups);
++ flock($fl{fh},LOCK_UN)
++ or warn "Unable to unlock lockfile $fl{file}: $!";
++ close($fl{fh})
++ or warn "Unable to close lockfile $fl{file}: $!";
++ unlink($fl{file})
++ or warn "Unable to unlink locfile $fl{file}: $!";
}
--sub quit
--{
-- DEBUG("quitting >$_[0]<\n");
-- my $u;
++
++
++
++=head1 QUIT
++
++These functions are exported with the :quit tag.
++
++=head2 quit
++
++ quit()
++
++Exits the program by calling die after running some cleanups.
++
++This should be replaced with an END handler which runs the cleanups
++instead. (Or possibly a die handler, if the cleanups are important)
++
++=cut
++
++sub quit {
++ print DEBUG "quitting >$_[0]<\n";
- local ($u);
+++ my ($u);
while ($u= $cleanups[$#cleanups]) { &$u; }
die "*** $_[0]\n";
}
--package Debbugs::Config; # assumes Some/Module.pm
++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($gSubmitList $gMaintList $gQuietList $gForwardList),
++ qw($gDoneList $gRequestList $gSubmitterList $gControlList),
++ qw($gSummaryList $gMirrorList $gMailer $gBug),
++ qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity),
++ qw($gShowSeverities $gBounceFroms $gConfigDir $gSpoolDir),
++ qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile),
++ qw($gMaintainerFileOverride $gPseudoDescFile $gPackageSource),
+++ qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap),
++ qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities),
+++ qw(%gSearchEstraier),
++ ],
++ config => [qw(%config)],
++ );
++ @EXPORT_OK = ();
++ Exporter::export_ok_tags(qw(globals config));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++use File::Basename qw(dirname);
++use IO::File;
++use Safe;
++
++=head1 CONFIGURATION VARIABLES
++
++=head2 General Configuration
++
++=over
++
++=cut
++
++# read in the files;
++%config = ();
++read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config');
++
++=item email_domain
++
++The email domain of the bts
++
++=cut
++
++set_default(\%config,'email_domain','bugs.something');
++
++=item list_domain
++
++The list domain of the bts, defaults to the email domain
++
++=cut
++
++set_default(\%config,'list_domain',$config{email_domain});
++
++=item web_host
++
++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
++
++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
++
++Full path of the web domain where bugs are kept, defaults to the
++concatenation of L</web_host> and L</web_host_bug_dir>
++
++=cut
++
++set_default(\%config,'web_domain',$config{web_host}.'/'.$config{web_host_bug_dir});
++
++=item html_suffix
++
++Suffix of html pages, defaults to .html
++
++=cut
++
++set_default(\%config,'html_suffix','.html');
++
++=item cgi_domain
++
++Full path of the web domain where cgi scripts are kept. Defaults to
++the concatentation of L</web_host> and cgi.
++
++=cut
++
++set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi');
++
++=item mirrors
++
++List of mirrors [What these mirrors are used for, no one knows.]
++
++=cut
++
++
++set_default(\%config,'mirrors',[]);
++
++=item package_pages
++
++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.
++
++=cut
++
++
++set_default(\%config,'package_pages',undef);
++
++=item subscription_domain
++
++Domain where subscriptions to package lists happen
++
++=cut
++
++
++set_default(\%config,'subscription_domain',undef);
++
++=back
--BEGIN
--{ use Exporter ();
-- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
--
-- # set the version for version checking
-- $VERSION = 1.00;
++=cut
-- @ISA = qw(Exporter);
-- @EXPORT = qw(%Globals %GTags %Strong %Severity );
-- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
-- # your exported package globals go here,
-- # as well as any optionally exported functions
-- @EXPORT_OK = qw(%Globals %GTags %Severity %Strong &ParseConfigFile &ParseXMLConfigFile);
++=head2 Project Identification
++
++=over
++
++=item project
++
++Name of the project
++
++=cut
++
++set_default(\%config,'project','Something');
++
++=item project_title
++
++Name of this install of Debbugs, defaults to "L</project> Debbugs Install"
++
++=cut
++
++set_default(\%config,'project_title',"$config{project} Debbugs Install");
++
++=item maintainer
++
++Name of the maintainer of this debbugs install
++
++=cut
++
++set_default(\%config,'maintainer','Local DebBugs Owner');
++
++=item maintainer_webpage
++
++Webpage of the maintainer of this install of debbugs
++
++=cut
++
++set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner");
++
++=item maintainer_email
++
++Email address of the maintainer of this Debbugs install
++
++=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
++
++=cut
++
++set_default(\%config,'unknown_maintainer_email',$config{maintainer_email});
++
++=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
++
++=back
++
++=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');
++
++=head2 Misc Options
++
++=cut
++
++set_default(\%config,'mailer','exim');
++set_default(\%config,'bug','bug');
++set_default(\%config,'bugs','bugs');
++set_default(\%config,'remove_age',28);
++
++set_default(\%config,'save_old_bugs',1);
++
++set_default(\%config,'default_severity','normal');
++set_default(\%config,'show_severities','critical, grave, normal, minor, wishlist');
++set_default(\%config,'strong_severities',[qw(critical grave)]);
++set_default(\%config,'severity_list',[qw(critical grave normal wishlist)]);
++set_default(\%config,'severity_display',{critical => "Critical $config{bugs}",
++ grave => "Grave $config{bugs}",
++ normal => "Normal $config{bugs}",
++ wishlist => "Wishlist $config{bugs}",
++ });
++
++set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed stable)]);
++
++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');
++set_default(\%config,'incoming_dir','incoming');
++set_default(\%config,'web_dir','/var/lib/debbugs/www');
++set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt');
++
++set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers');
++set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override');
++set_default(\%config,'pseduo_desc_file',$config{config_dir}.'/pseudo-packages.description');
++set_default(\%config,'package_source',$config{config_dir}.'/indices/sources');
++
+++set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg');
+++#set_default(\%config,'version_packages_dir',$config{spool_dir}'/../versions/pkg');
+++
++
++sub read_config{
++ my ($conf_file) = @_;
++ # first, figure out what type of file we're reading in.
++ my $fh = new IO::File $conf_file,'r'
++ or die "Unable to open configuration file $conf_file for reading: $!";
++ # A new version configuration file must have a comment as its first line
++ my $first_line = <$fh>;
++ my ($version) = $first_line =~ /VERSION:\s*(\d+)/i;
++ if (defined $version) {
++ if ($version == 1) {
++ # Do something here;
++ die "Version 1 configuration files not implemented yet";
++ }
++ else {
++ die "Version $version configuration files are not supported";
++ }
++ }
++ else {
++ # Ugh. Old configuration file
++ # What we do here is we create a new Safe compartment
++ # so fucked up crap in the config file doesn't sink us.
++ my $cpt = new Safe or die "Unable to create safe compartment";
++ # perldoc Opcode; for details
- $cpt->permit('require');
+++ $cpt->permit('require',':filesys_read','entereval','caller','pack','unpack','dofile');
++ $cpt->reval(q($gMaintainerFile = 'FOOOO'));
++ $cpt->reval(qq(require '$conf_file';));
++ die "Error in configuration file: $@" if $@;
++ # Now what we do is check out the contents of %EXPORT_TAGS to see exactly which variables
++ # we want to glob in from the configuration file
++ for my $variable (@{$EXPORT_TAGS{globals}}) {
++ my ($hash_name,$glob_name,$glob_type) = __convert_name($variable);
++ my $var_glob = $cpt->varglob($glob_name);
++ my $value; #= $cpt->reval("return $variable");
++ #print STDERR $value,qq(\n);
++ if (defined $var_glob) {{
++ no strict 'refs';
++ if ($glob_type eq '%') {
++ $value = {%{*{$var_glob}}};
++ }
++ elsif ($glob_type eq '@') {
++ $value = [@{*{$var_glob}}];
++ }
++ else {
++ $value = ${*{$var_glob}};
++ }
++ # We punt here, because we can't tell if the value was
++ # defined intentionally, or if it was just left alone;
++ # this tries to set sane defaults.
++ set_default(\%config,$hash_name,$value) if defined $value;
++ }}
++ }
++ }
}
--use vars @EXPORT_OK;
--use Debbugs::Common;
--use Debbugs::Email;
--
--# initialize package globals, first exported ones
--%Severity = ();
--%Strong = ();
--$Severity{ 'Text' } = ();
--%GTags = ();
--%Globals = ( "debug" => 0,
-- "verbose" => 0,
-- "quiet" => 0,
-- ##### domains
-- "email-domain" => "bugs.domain.com",
-- "list-domain" => "lists.domain.com",
-- "web-domain" => "web.domain.com",
-- "cgi-domain" => "cgi.domain.com",
-- ##### identification
-- "project-short" => "debbugs",
-- "project-long" => "Debbugs Test Project",
-- "owner-name" => "Fred Flintstone",
-- "owner-email" => "owner\@bugs.domain.com",
-- ##### directories
-- "work-dir" => "/var/lib/debbugs/spool",
-- "spool-dir" => "/var/lib/debbugs/spool/incoming",
-- "www-dir" => "/var/lib/debbugs/www",
-- "doc-dir" => "/var/lib/debbugs/www/txt",
-- ##### files
-- "maintainer-file" => "/etc/debbugs/Maintainers",
-- "pseudo-description" => "/etc/debbugs/pseudo-packages.description");
--
--my %ConfigMap = (
-- "Email Domain" => "email-domain",
-- "List Domain" => "list-domain",
-- "Web Domain" => "web-domain",
-- "CGI Domain" => "cgi-domain",
-- "Short Name" => "project-short",
-- "Long Name" => "project-long",
-- "Owner Name" => "owner-name",
-- "Owner Email" => "owner-email",
-- "Errors Email" => "errors-email",
-- "Owner Webpage" => "owner-webpage",
-- "Spool Dir" => "spool-dir",
-- "Work Dir" => "work-dir",
-- "Web Dir" => "www-dir",
-- "Doc Dir" => "doc-dir",
-- "Template Dir" => "template-dir",
-- "Not-Don-Con" => "not-don-con",
-- "Maintainer File" => "maintainer-file",
-- "Pseudo Description File" => "pseudo-description",
-- "Submit List" => "submit-list",
-- "Maint List" => "maint-list",
-- "Quiet List" => "quiet-list",
-- "Forwarded List" => "forwarded-list",
-- "Done List" => "done-list",
-- "Request List" => "request-list",
-- "Submitter List" => "submitter-list",
-- "Control List" => "control-list",
-- "Summary List" => "summary-list",
-- "Mirror List" => "mirror-list",
-- "Mailer" => "mailer",
-- "Singular Term" => "singluar",
-- "Plural Term" => "plural",
-- "Expire Age" => "expire-age",
-- "Save Expired Bugs" => "save-expired",
-- "Mirrors" => "mirrors",
-- "Default Severity" => "default-severity",
-- "Normal Severity" => "normal-severity",
-- );
--
--my %GTagsMap = (
-- "email-domain" => "EMAIL_DOMAIN",
-- "list-domain" => "LIST_DOMAIN",
-- "web-domain" => "WEB_DOMAIN",
-- "cgi-domain" => "CGI_DOMAIN",
-- "project-short" => "SHORT_NAME",
-- "project-long" => "LONG_NAME",
-- "owner-name" => "OWNER_NAME",
-- "owner-email" => "OWNER_EMAIL",
-- "submit-list" => "SUBMIT_LIST",
-- "quiet-list" => "QUIET_LIST",
-- "forwarded-list" => "FORWARDED_LIST",
-- "done-list" => "DONE_LIST",
-- "request-list" => "REQUEST_LIST",
-- "submitter-list" => "SUBMITTER_LIST",
-- "control-list" => "CONTROL_LIST",
-- "summary-list" => "SUMMARY_LIST",
-- "mirror-list" => "MIRROR_LIST",
-- "mirrors" => "MIRRORS"
-- );
--
--sub strip
--{ my $string = $_[0];
-- chop $string while $string =~ /\s$/;
-- return $string;
++sub __convert_name{
++ my ($variable) = @_;
++ my $hash_name = $variable;
++ $hash_name =~ s/^([\$\%\@])g//;
++ my $glob_type = $1;
++ my $glob_name = 'g'.$hash_name;
++ $hash_name =~ s/^([A-Z]+)/lc($1)/e;
++ $hash_name =~ s/([A-Z]+)/'_'.lc($1)/ge;
++ return $hash_name unless wantarray;
++ return ($hash_name,$glob_name,$glob_type);
}
--#############################################################################
--# Read Config File and parse
--#############################################################################
--sub ParseConfigFile
--{ my $configfile = $_[0];
-- my @config;
-- my $votetitle = '';
-- my $ballottype = '';
--
-- #load config file
-- print "V: Loading Config File\n" if $Globals{ "verbose" };
-- open(CONFIG,$configfile) or &fail( "E: Unable to open `$configfile'" );
-- @config = <CONFIG>;
-- close CONFIG;
--
-- #parse config file
-- print "V: Parsing Config File\n" if $Globals{ "verbose" };
-- print "D3: Parse Config:\n@config\n" if $Globals{ 'debug' } > 2;
-- print "D1: Configuration\n" if $Globals{ 'debug' };
--
-- for( my $i=0; $i<=$#config; $i++)
-- { $_ = $config[$i];
-- chop $_;
-- next unless length $_;
-- next if /^#/;
--
-- if ( /^([^:=]*)\s*[:=]\s*([^#]*)/i ) {
-- my $key = strip( $1 );
-- my $value = strip( $2 );
-- $value = "" if(!defined($value));
-- if ( $key =~ /Severity\s+#*(\d+)\s*(.*)/ ) {
-- my $options = $2;
-- my $severity = $1;
-- if( $options =~ /\btext\b/ ) {
-- $Severity{ 'Text' }{ $severity } = $value;
-- print "D2: (config) Severity $severity text = $value\n" if $Globals{ 'debug' } > 1;
-- } else {
-- $Severity{ $1 } = $value;
-- print "D2: (config) Severity $severity = $value" if $Globals{ 'debug' } > 1;
-- if( $options =~ /\bdefault\b/ ) {
-- $Globals{ "default-severity" } = $severity;
-- print ", default" if $Globals{ 'debug' } > 1;
-- }
-- if( $options =~ /\bstrong\b/ ) {
-- $Strong{ $severity } = 1;
-- print ", strong" if $Globals{ 'debug' } > 1;
-- }
-- print "\n" if $Globals{ 'debug' } > 1;
-- }
-- next;
-- } else {
-- my $map = $ConfigMap{$key};
-- if(defined($map)) {
-- $Globals{ $map } = $value;
-- print "$key = '$value'" if $Globals{ 'debug' } > 1;
-- my $gtag = $GTagsMap{ $map };
-- if(defined($gtag)) {
-- $GTags{ $gtag } = $value;
-- print "GTag = '$gtag'" if $Globals{ 'debug' } > 1;
-- }
-- print "\n" if $Globals{ 'debug' } > 1;
-- next;
-- } else {
-- print "$key\n";
-- }
--
-- }
-- }
-- print "Unknown line in config!($_)\n";
-- next;
-- }
-- return @config;
++# set_default
++
++# sets the configuration hash to the default value if it's not set,
++# otherwise doesn't do anything
++# If $USING_GLOBALS, then sets an appropriate global.
++
++sub set_default{
++ my ($config,$option,$value) = @_;
++ # update the configuration value
++ if (not $USING_GLOBALS and not exists $config{$option}) {
++ $config{$option} = $value;
++ }
++ else {
++ # Need to check if a value has already been set in a global
++ }
++ if ($USING_GLOBALS) {{
++ # fix up the variable name
++ my $varname = 'g'.join('',map {ucfirst $_} $option);
++ # Fix stupid HTML names
++ $varname =~ s/Html/HTML/;
++ no strict 'refs';
++ my $ref = ref $config{$option} || 'SCALAR';
++ *{"Debbugs::Config::${varname}"} = $config{$option};
++ }}
++}
++
++
++### import magick
++
++# All we care about here is whether we've been called with the globals option;
++# if so, then we need to export some symbols back up; otherwise we call exporter.
++
++sub import {
++ if (grep $_ eq ':globals', @_) {
++ $USING_GLOBALS=1;
++ for my $variable (@{$EXPORT_TAGS{globals}}) {
++ my $tmp = $variable;
++ no strict 'refs';
++ # Yes, I don't care if these are only used once
++ no warnings 'once';
++ # No, it doesn't bother me that I'm assigning an undefined value to a typeglob
++ no warnings 'misc';
++ my ($hash_name,$glob_name,$glob_type) = __convert_name($variable);
++ $tmp =~ s/^[\%\$\@]//;
++ *{"Debbugs::Config::${tmp}"} = ref($config{$hash_name})?$config{$hash_name}:\$config{$hash_name};
++ }
++ }
++ Debbugs::Config->export_to_level(1,@_);
}
--END { } # module clean-up code here (global destructor)
++
++1;
--- /dev/null
--- /dev/null
++
++package Debbugs::Estraier;
++
++=head1 NAME
++
++Debbugs::Estraier -- Routines for interfacing bugs to HyperEstraier
++
++=head1 SYNOPSIS
++
++use Debbugs::Estraier;
++
++
++=head1 DESCRIPTION
++
++
++=head1 BUGS
++
++None known.
++
++=cut
++
++use warnings;
++use strict;
++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
++use base qw(Exporter);
++use Debbugs::Log;
++#use Params::Validate;
++use Search::Estraier;
++use Date::Manip;
++use Debbugs::Common qw(getbuglocation getbugcomponent readbug);
++
++
++BEGIN{
++ ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/;
++ $DEBUG = 0 unless defined $DEBUG;
++
++ @EXPORT = ();
++ %EXPORT_TAGS = (add => [qw(add_bug_log add_bug_message)],
++ );
++ @EXPORT_OK = ();
++ Exporter::export_ok_tags(qw(add));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++
++sub add_bug_log{
++ my ($est,$bug_num) = @_;
++
++ # We want to read the entire bug log, pulling out individual
++ # messages, and shooting them through hyper estraier
++
++ my $location = getbuglocation($bug_num,'log');
++ my $bug_log = getbugcomponent($bug_num,'log',$location);
++ my $log_fh = new IO::File $bug_log, 'r' or
++ die "Unable to open bug log $bug_log for reading: $!";
++
++ my $log = Debbugs::Log->new($log_fh) or
++ die "Debbugs::Log was unable to be initialized";
++
++ my %seen_msg_ids;
++ my $msg_num=0;
++ my $status = {};
++ if (my $location = getbuglocation($bug_num,'summary')) {
++ $status = readbug($bug_num,$location);
++ }
++ while (my $record = $log->read_record()) {
++ $msg_num++;
++ next unless $record->{type} eq 'incoming-recv';
++ my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
++ next if defined $msg_id and exists $seen_msg_ids{$msg_id};
++ $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
++ next if $msg_id =~ /handler\..+\.ack(?:info)?\@/;
++ add_bug_message($est,$record->{text},$bug_num,$msg_num,$status)
++ }
+++ return $msg_num;
+++}
+++
+++=head2 remove_old_message
+++
+++ remove_old_message($est,300000,50);
+++
+++Removes all messages which are no longer in the log
+++
+++=cut
+++
+++sub remove_old_messages{
+++ my ($est,$bug_num,$max_message) = @_;
+++ # remove records which are no longer present in the log (uri > $msg_num)
+++ my $cond = new Search::Estraier::Condition;
+++ $cond->add_attr('@uri STRBW '.$bug_num.'/');
+++ $cond->set_max(50);
+++ my $skip;
+++ my $nres;
+++ while ($nres = $est->search($cond,0) and $nres->doc_num > 0){
+++ for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) {
+++ my $uri = $rdoc->uri;
+++ my ($this_message) = $uri =~ m{/(\d+)$};
+++ next unless $this_message > $max_message;
+++ $est->out_doc_by_uri($uri);
+++ }
+++ last unless $nres->doc_num >= $cond->max;
+++ $cond->set_skip($cond->skip+$cond->max);
+++ }
+++
++}
++
++sub add_bug_message{
++ my ($est,$bug_message,$bug_num,
++ $msg_num,$status) = @_;
++
++ my $doc;
++ my $uri = "$bug_num/$msg_num";
++ $doc = $est->get_doc_by_uri($uri);
++ $doc = new Search::Estraier::Document if not defined $doc;
++ $doc->add_text($bug_message);
++
++ # * @id : the ID number determined automatically when the document is registered.
++ # * @uri : the location of a document which any document should have.
++ # * @digest : the message digest calculated automatically when the document is registered.
++ # * @cdate : the creation date.
++ # * @mdate : the last modification date.
++ # * @adate : the last access date.
++ # * @title : the title used as a headline in the search result.
++ # * @author : the author.
++ # * @type : the media type.
++ # * @lang : the language.
++ # * @genre : the genre.
++ # * @size : the size.
++ # * @weight : the scoring weight.
++ # * @misc : miscellaneous information.
++ my @attr = qw(status subject date submitter package tags severity);
++ # parse the date
++ my ($date) = $bug_message =~ /^Date:\s+(.+?)\s*$/mi;
++ $doc->add_attr('@cdate' => $date);
++ # parse the title
++ my ($subject) = $bug_message =~ /^Subject:\s+(.+?)\s*$/mi;
++ $doc->add_attr('@title' => $subject);
++ # parse the author
++ my ($author) = $bug_message =~ /^From:\s+(.+?)\s*$/mi;
++ $doc->add_attr('@author' => $author);
++ # create the uri
++ $doc->add_attr('@uri' => $uri);
++ foreach my $attr (@attr) {
++ $doc->add_attr($attr => $status->{$attr});
++ }
++ print STDERR "adding $uri\n" if $DEBUG;
++ # Try a bit harder if estraier is returning timeouts
++ my $attempt = 5;
++ while ($attempt > 0) {
++ $est->put_doc($doc) and last;
++ my $status = $est->status;
++ $attempt--;
++ print STDERR "Failed to add $uri\n".$status."\n";
++ last unless $status =~ /^5/;
++ sleep 20;
++ }
++
++}
++
++
++1;
++
++
++__END__
++
++
++
++
++
++
BEGIN {
$VERSION = 1.00;
-- @ISA = qw(Exporter);
-- @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
-- binarytosource sourcetobinary);
++ @EXPORT = ();
- %EXPORT_TAGS = (versions => [qw(getverions)],
+++ %EXPORT_TAGS = (versions => [qw(getversions)],
++ mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs),
++ qw(binarytosource sourcetobinary)
++ ],
++ );
++ @EXPORT_OK = ();
++ Exporter::export_ok_tags(qw(versions mapping));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
}
use Fcntl qw(O_RDONLY);
--- /dev/null
--- /dev/null
--- /dev/null
+++package Debbugs::SOAP::Status;
+++
+++# This is a hack that must be removed
+++require '/home/don/projects/debbugs/source/cgi/common.pl';
+++#use Debbugs::Status qw(getbugstatus);
+++
+++sub get_status {
+++ my ($class, @bugs) = @_;
+++ @bugs = map {ref($_)?@{$_}:$_} @bugs;
+++
+++ my %s;
+++ foreach (@bugs) {
+++ my $hash = getbugstatus($_);
+++ if (scalar(%{$hash}) > 0) {
+++ $s{$_} = $hash;
+++ }
+++ }
+++
+++ return \%s;
+++}
+++
+++1;
--- /dev/null
--- /dev/null
- %EXPORT_TAGS = (status => [qw(splitpackages getbugstatus)],
++
++package Debbugs::Status;
++
++=head1 NAME
++
++Debbugs::Status -- Routines for dealing with summary and status files
++
++=head1 SYNOPSIS
++
++use Debbugs::Status;
++
++
++=head1 DESCRIPTION
++
++This module is a replacement for the parts of errorlib.pl which write
++and read status and summary files.
++
++It also contains generic routines for returning information about the
++status of a particular bug
++
++=head1 FUNCTIONS
++
++=cut
++
++use warnings;
++use strict;
++use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
++use base qw(Exporter);
++
++use Params::Validate qw(validate_with :types);
++use Debbugs::Common qw(:util :lock);
++use Debbugs::Config qw(:config);
+++use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
+++
++
++BEGIN{
++ $VERSION = 1.00;
++ $DEBUG = 0 unless defined $DEBUG;
++
++ @EXPORT = ();
- qw(),
+++ %EXPORT_TAGS = (status => [qw(splitpackages)],
++ read => [qw(readbug lockreadbug)],
++ write => [qw(writebug makestatus unlockwritebug)],
++ versions => [qw(addfoundversion addfixedversion),
- Exporter::export_ok_tags(qw(splitpackages));
++ ],
++ );
++ @EXPORT_OK = ();
- $data{$field}{@{$data{${field}_versions}}} =
- ('') x (@{$data{${field}_date}} - @{$data{${field}_versions}}),
- @{$data{${field}_date}};
+++ Exporter::export_ok_tags(qw(status read write versions));
++ $EXPORT_TAGS{all} = [@EXPORT_OK];
++}
++
++
++=head2 readbug
++
++ readbug($bug_number,$location)
++
++Reads a summary file from the archive given a bug number and a bug
++location. Valid locations are those understood by L</getbugcomponent>
++
++=cut
++
++
++my %fields = (originator => 'submitter',
++ date => 'date',
++ subject => 'subject',
++ msgid => 'message-id',
++ 'package' => 'package',
++ keywords => 'tags',
++ done => 'done',
++ forwarded => 'forwarded-to',
++ mergedwith => 'merged-with',
++ severity => 'severity',
++ owner => 'owner',
++ found_versions => 'found-in',
++ found_date => 'found-date',
++ fixed_versions => 'fixed-in',
++ fixed_date => 'fixed-date',
++ blocks => 'blocks',
++ blockedby => 'blocked-by',
++ );
++
++# Fields which need to be RFC1522-decoded in format versions earlier than 3.
++my @rfc1522_fields = qw(originator subject done forwarded owner);
++
++=head2 readbug
++
++ readbug($bug_num,$location);
++ readbug($bug_num)
++
++
++Retreives the information from the summary files for a particular bug
++number. If location is not specified, getbuglocation is called to fill
++it in.
++
++=cut
++
++sub readbug {
++ my ($lref, $location) = @_;
++ if (not defined $location) {
++ $location = getbuglocation($lref,'summary');
++ return undef if not defined $location;
++ }
++ my $status = getbugcomponent($lref, 'summary', $location);
++ return undef unless defined $status;
++ my $status_fh = new IO::File $status, 'r' or
++ warn "Unable to open $status for reading: $!" and return undef;
++
++ my %data;
++ my @lines;
++ my $version = 2;
++ local $_;
++
++ while (<$status_fh>) {
++ chomp;
++ push @lines, $_;
++ $version = $1 if /^Format-Version: ([0-9]+)/i;
++ }
++
++ # Version 3 is the latest format version currently supported.
++ return undef if $version > 3;
++
++ my %namemap = reverse %fields;
++ for my $line (@lines) {
++ if ($line =~ /(\S+?): (.*)/) {
++ my ($name, $value) = (lc $1, $2);
++ $data{$namemap{$name}} = $value if exists $namemap{$name};
++ }
++ }
++ for my $field (keys %fields) {
++ $data{$field} = '' unless exists $data{$field};
++ }
++
++ $data{severity} = $config{default_severity} if $data{severity} eq '';
++ for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
++ $data{$field} = [split ' ', $data{$field}];
++ }
++ for my $field (qw(found fixed)) {
- local ($lref, $location) = @_;
+++ @{$data{$field}}{@{$data{"${field}_versions"}}} =
+++ (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
+++ @{$data{"${field}_date"}});
++ }
++
++ if ($version < 3) {
++ for my $field (@rfc1522_fields) {
++ $data{$field} = decode_rfc1522($data{$field});
++ }
++ }
++
++ return \%data;
++}
++
++=head2 lockreadbug
++
++ lockreadbug($bug_num,$location)
++
++Performs a filelock, then reads the bug; the bug is unlocked if the
++return is undefined, otherwise, you need to call unfilelock or
++unlockwritebug.
++
++See readbug above for information on what this returns
++
++=cut
++
++sub lockreadbug {
- if (exists $data{$field}) {
- $data{"${field}_date"} =
- [map {$data{$field}{$_}||''} keys %{$data{$field}}];
+++ my ($lref, $location) = @_;
++ &filelock("lock/$lref");
++ my $data = readbug($lref, $location);
++ &unfilelock unless defined $data;
++ return $data;
++}
++
++my @v1fieldorder = qw(originator date subject msgid package
++ keywords done forwarded mergedwith severity);
++
++=head2 makestatus
++
++ my $content = makestatus($status,$version)
++ my $content = makestatus($status);
++
++Creates the content for a status file based on the $status hashref
++passed.
++
++Really only useful for writebug
++
++Currently defaults to version 2 (non-encoded rfc1522 names) but will
++eventually default to version 3. If you care, you should specify a
++version.
++
++=cut
++
++sub makestatus {
++ my ($data,$version) = @_;
++ $version = 2 unless defined $version;
++
++ my $contents = '';
++
++ my %newdata = %$data;
++ for my $field (qw(found fixed)) {
- print IDXNEW $line if ($line ne "" && $line[1] == $ref);
+++ if (exists $newdata{$field}) {
+++ $newdata{"${field}_date"} =
+++ [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
++ }
++ }
++
++ for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
++ $newdata{$field} = [split ' ', $newdata{$field}];
++ }
++
++ if ($version < 3) {
++ for my $field (@rfc1522_fields) {
++ $newdata{$field} = encode_rfc1522($newdata{$field});
++ }
++ }
++
++ if ($version == 1) {
++ for my $field (@v1fieldorder) {
++ if (exists $newdata{$field}) {
++ $contents .= "$newdata{$field}\n";
++ } else {
++ $contents .= "\n";
++ }
++ }
++ } elsif ($version == 2 or $version == 3) {
++ # Version 2 or 3. Add a file format version number for the sake of
++ # further extensibility in the future.
++ $contents .= "Format-Version: $version\n";
++ for my $field (keys %fields) {
++ if (exists $newdata{$field} and $newdata{$field} ne '') {
++ # Output field names in proper case, e.g. 'Merged-With'.
++ my $properfield = $fields{$field};
++ $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
++ $contents .= "$properfield: $newdata{$field}\n";
++ }
++ }
++ }
++
++ return $contents;
++}
++
++=head2 writebug
++
++ writebug($bug_num,$status,$location,$minversion,$disablebughook)
++
++Writes the bug status and summary files out.
++
++Skips writting out a status file if minversion is 2
++
++Does not call bughook if disablebughook is true.
++
++=cut
++
++sub writebug {
++ my ($ref, $data, $location, $minversion, $disablebughook) = @_;
++ my $change;
++
++ my %outputs = (1 => 'status', 2 => 'summary');
++ for my $version (keys %outputs) {
++ next if defined $minversion and $version < $minversion;
++ my $status = getbugcomponent($ref, $outputs{$version}, $location);
++ &quit("can't find location for $ref") unless defined $status;
++ open(S,"> $status.new") || &quit("opening $status.new: $!");
++ print(S makestatus($data, $version)) ||
++ &quit("writing $status.new: $!");
++ close(S) || &quit("closing $status.new: $!");
++ if (-e $status) {
++ $change = 'change';
++ } else {
++ $change = 'new';
++ }
++ rename("$status.new",$status) || &quit("installing new $status: $!");
++ }
++
++ # $disablebughook is a bit of a hack to let format migration scripts use
++ # this function rather than having to duplicate it themselves.
++ &bughook($change,$ref,$data) unless $disablebughook;
++}
++
++=head2 unlockwritebug
++
++ unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
++
++Writes a bug, then calls unfilelock; see writebug for what these
++options mean.
++
++=cut
++
++sub unlockwritebug {
++ writebug(@_);
++ &unfilelock;
++}
++
++=head1 VERSIONS
++
++The following functions are exported with the :versions tag
++
++=head2 addfoundversions
++
++ addfoundversions($status,$package,$version,$isbinary);
++
++
++
++=cut
++
++
++sub addfoundversions {
++ my $data = shift;
++ my $package = shift;
++ my $version = shift;
++ my $isbinary = shift;
++ return unless defined $version;
++ undef $package if $package =~ m[(?:\s|/)];
++ my $source = $package;
++
++ if (defined $package and $isbinary) {
++ my @srcinfo = binarytosource($package, $version, undef);
++ if (@srcinfo) {
++ # We know the source package(s). Use a fully-qualified version.
++ addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
++ return;
++ }
++ # Otherwise, an unqualified version will have to do.
++ undef $source;
++ }
++
++ # Strip off various kinds of brain-damage.
++ $version =~ s/;.*//;
++ $version =~ s/ *\(.*\)//;
++ $version =~ s/ +[A-Za-z].*//;
++
++ foreach my $ver (split /[,\s]+/, $version) {
++ my $sver = defined($source) ? "$source/$ver" : '';
++ unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
++ push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
++ }
++ @{$data->{fixed_versions}} =
++ grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
++ }
++}
++
++sub removefoundversions {
++ my $data = shift;
++ my $package = shift;
++ my $version = shift;
++ my $isbinary = shift;
++ return unless defined $version;
++ undef $package if $package =~ m[(?:\s|/)];
++ my $source = $package;
++
++ if (defined $package and $isbinary) {
++ my @srcinfo = binarytosource($package, $version, undef);
++ if (@srcinfo) {
++ # We know the source package(s). Use a fully-qualified version.
++ removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
++ return;
++ }
++ # Otherwise, an unqualified version will have to do.
++ undef $source;
++ }
++
++ foreach my $ver (split /[,\s]+/, $version) {
++ my $sver = defined($source) ? "$source/$ver" : '';
++ @{$data->{found_versions}} =
++ grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
++ }
++}
++
++sub addfixedversions {
++ my $data = shift;
++ my $package = shift;
++ my $version = shift;
++ my $isbinary = shift;
++ return unless defined $version;
++ undef $package if $package =~ m[(?:\s|/)];
++ my $source = $package;
++
++ if (defined $package and $isbinary) {
++ my @srcinfo = binarytosource($package, $version, undef);
++ if (@srcinfo) {
++ # We know the source package(s). Use a fully-qualified version.
++ addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
++ return;
++ }
++ # Otherwise, an unqualified version will have to do.
++ undef $source;
++ }
++
++ # Strip off various kinds of brain-damage.
++ $version =~ s/;.*//;
++ $version =~ s/ *\(.*\)//;
++ $version =~ s/ +[A-Za-z].*//;
++
++ foreach my $ver (split /[,\s]+/, $version) {
++ my $sver = defined($source) ? "$source/$ver" : '';
++ unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
++ push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
++ }
++ @{$data->{found_versions}} =
++ grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
++ }
++}
++
++sub removefixedversions {
++ my $data = shift;
++ my $package = shift;
++ my $version = shift;
++ my $isbinary = shift;
++ return unless defined $version;
++ undef $package if $package =~ m[(?:\s|/)];
++ my $source = $package;
++
++ if (defined $package and $isbinary) {
++ my @srcinfo = binarytosource($package, $version, undef);
++ if (@srcinfo) {
++ # We know the source package(s). Use a fully-qualified version.
++ removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
++ return;
++ }
++ # Otherwise, an unqualified version will have to do.
++ undef $source;
++ }
++
++ foreach my $ver (split /[,\s]+/, $version) {
++ my $sver = defined($source) ? "$source/$ver" : '';
++ @{$data->{fixed_versions}} =
++ grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
++ }
++}
++
++
++
++=head2 splitpackages
++
++ splitpackages($pkgs)
++
++Split a package string from the status file into a list of package names.
++
++=cut
++
++sub splitpackages {
++ my $pkgs = shift;
++ return unless defined $pkgs;
++ return map lc, split /[ \t?,()]+/, $pkgs;
++}
++
++
++=head2 bug_archiveable
++
++ bug_archiveable(ref => $bug_num);
++
++Options
++
++=over
++
++=item ref -- bug number (required)
++
++=item status -- Status hashref (optional)
++
++=item version -- Debbugs::Version information (optional)
++
++=item days_until -- return days until the bug can be archived
++
++=back
++
++Returns 1 if the bug can be archived
++Returns 0 if the bug cannot be archived
++
++If days_until is true, returns the number of days until the bug can be
++archived, -1 if it cannot be archived.
++
++=cut
++
++sub bug_archiveable{
++ my %param = validate_with(params => \@_,
++ spec => {ref => {type => SCALAR,
++ regex => qr/^\d+$/,
++ },
++ status => {type => HASHREF,
++ optional => 1,
++ },
++ version => {type => HASHREF,
++ optional => 1,
++ },
++ days_until => {type => BOOLEAN,
++ default => 0,
++ },
++ },
++ );
++ # read the status information
++ # read the version information
++ # Bugs can be archived if they are
++ # 1. Closed
++ # 2. Fixed in unstable if tagged unstable
++ # 3. Fixed in stable if tagged stable
++ # 4. Fixed in testing if tagged testing
++ # 5. Fixed in experimental if tagged experimental
++ # 6. at least 28 days have passed since the last action has occured or the bug was closed
++}
++
++=head1 PRIVATE FUNCTIONS
++
++=cut
++
++sub update_realtime {
++ my ($file, $bug, $new) = @_;
++
++ # update realtime index.db
++
++ open(IDXDB, "<$file") or die "Couldn't open $file";
++ open(IDXNEW, ">$file.new");
++
++ my $line;
++ my @line;
++ while($line = <IDXDB>) {
++ @line = split /\s/, $line;
++ last if ($line[1] >= $bug);
++ print IDXNEW $line;
++ $line = "";
++ }
++
++ if ($new eq "NOCHANGE") {
- "$gSpoolDir/index.db.realtime",
+++ print IDXNEW $line if ($line ne "" && $line[1] == $bug);
++ } elsif ($new eq "REMOVE") {
++ 0;
++ } else {
++ print IDXNEW $new;
++ }
++ if ($line ne "" && $line[1] > $bug) {
++ print IDXNEW $line;
++ $line = "";
++ }
++
++ print IDXNEW while(<IDXDB>);
++
++ close(IDXNEW);
++ close(IDXDB);
++
++ rename("$file.new", $file);
++
++ return $line;
++}
++
++sub bughook_archive {
++ my $ref = shift;
++ &filelock("debbugs.trace.lock");
++ &appendfile("debbugs.trace","archive $ref\n");
++ my $line = update_realtime(
- update_realtime("$gSpoolDir/index.archive.realtime",
+++ "$config{spool_dir}/index.db.realtime",
++ $ref,
++ "REMOVE");
- my $severity = $gDefaultSeverity;
+++ update_realtime("$config{spool_dir}/index.archive.realtime",
++ $ref, $line);
++ &unfilelock;
++}
++
++sub bughook {
++ my ( $type, $ref, $data ) = @_;
++ &filelock("debbugs.trace.lock");
++
++ &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
++
++ my $whendone = "open";
- update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
+++ my $severity = $config{default_severity};
++ (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
++ $pkglist =~ s/^,+//;
++ $pkglist =~ s/,+$//;
++ $whendone = "forwarded" if length $data->{forwarded};
++ $whendone = "done" if length $data->{done};
++ $severity = $data->{severity} if length $data->{severity};
++
++ my $k = sprintf "%s %d %d %s [%s] %s %s\n",
++ $pkglist, $ref, $data->{date}, $whendone,
++ $data->{originator}, $severity, $data->{keywords};
++
+++ update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
++
++ &unfilelock;
++}
++
++
++
++
++1;
++
++__END__
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use base qw(Exporter);
+++use Debbugs::Config qw(:globals);
+++
BEGIN {
($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/;
$DEBUG = 0 unless defined $DEBUG;
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
- my $gSpoolDir = "/org/bugs.debian.org/spool";
- if (defined($debbugs::gSpoolDir)) {
- $gSpoolDir = $debbugs::gSpoolDir;
- }
--my $gSpoolPath = "/org/bugs.debian.org/spool";
---
# Obsolete compatability functions
sub read_usertags {
--- /dev/null
--- /dev/null
- $Debbugs::Config::gSpoolDir = $options{spool} if defined $options{spool};
++#!/usr/bin/perl
++# add_bug_to_estraier adds a log for a bug to the estaier db, 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 2006 by Don Armstrong <don@debian.org>.
++
++
++
++use warnings;
++use strict;
++
++
++use Getopt::Long;
++use Pod::Usage;
++
++=head1 NAME
++
++add_bug_to_estraier
++
++=head1 SYNOPSIS
++
++add_bug_to_estraier [options] < list_of_bugs_to_add
++
++ Options:
++ --debug, -d debugging level (Default 0)
++ --help, -h display this help
++ --man, -m display manual
++
++=head1 OPTIONS
++
++=over
++
++=item B<--url, -u>
++
++Url to the estraier node
++
++=item B<--user,-U>
++
++User to log onto the estraier node
++
++=item B<--pass,-P>
++
++Password to log onto the estraier node
++
++=item B<--spool,-s>
++
++Spool location; if not set defaults to /etc/debbugs/config
++
++=item B<--conf,-C>
++
++Configuration file; a set of key = value pairs separated by newlines;
++the long name of any option is the name that the configuration file
++takes
++
++=item B<--cron>
++
++Descend through the spool and add all of the bugs to estraier
++
++=item B<--timestamp>
++
++Use the timestamp file to only add new bugs; will lock the timestamp
++file to avoid racing with other invocations
++
++=item B<--debug, -d>
++
++Debug verbosity. (Default 0)
++
++=item B<--help, -h>
++
++Display brief useage information.
++
++=item B<--man, -m>
++
++Display this manual.
++
++=back
++
++
++=head1 EXAMPLES
++
++ test_bts --bug 7 --host donbugs.donarmstrong.com
++
++
++=cut
++
++
+++use Debbugs::Config qw(:globals);
++use Debbugs::Mail qw(send_mail_message);
++use Debbugs::MIME qw(create_mime_message);
++
++use Search::Estraier;
++use Debbugs::Estraier qw(:add);
++use File::Find;
++use File::stat;
++
++use vars qw($DEBUG $VERBOSE);
++
++# XXX parse config file
++
++my %options = (debug => 0,
++ help => 0,
++ man => 0,
++ url => undef,
++ user => undef,
++ passwd => undef,
++ spool => undef,
++ conf => undef,
++ cron => 0,
++ timestamp => undef,
++ );
++
++GetOptions(\%options,'url|u=s','user|U=s','passwd|P=s',
++ 'spool|s=s','conf|C=s','cron!','timestamp=s',
++ 'debug|d+','help|h|?','man|m');
++
++my $ERRORS = '';
++
++if (not defined $options{conf}) {
++ $ERRORS .= "--url must be set\n" if not defined $options{url};
++ $ERRORS .= "--user must be set\n" if not defined $options{user};
++ $ERRORS .= "--passwd must be set\n" if not defined $options{passwd};
++}
++else {
++ # Read the conf file
++ my $conf_fh = new IO::File $options{conf},'r'
++ or die "Unable to open $options{conf} for reading";
++ while (<$conf_fh>) {
++ chomp;
++ next if /^\s*\#/;
++ my ($key,$value) = split /\s*[:=]\s*/,$_,2;
++ $options{$key} = $value if defined $key and not defined $options{$key};
++ }
++ $ERRORS .= "url must be set\n" if not defined $options{url};
++ $ERRORS .= "user must be set\n" if not defined $options{user};
++ $ERRORS .= "passwd must be set\n" if not defined $options{passwd};
++}
++$ERRORS .= "--spool must be set if --cron is used\n" if
++ not defined $options{spool} and $options{cron};
++pod2usage($ERRORS) if length $ERRORS;
++
++pod2usage() if $options{help};
++pod2usage({verbose=>2}) if $options{man};
++
++
++$DEBUG = $options{debug};
++
++$Debbugs::Estraier::DEBUG = $DEBUG;
++$VERBOSE = 0;
++
++my $node = new Search::Estraier::Node (url => $options{url},
++ user => $options{user},
++ passwd => $options{passwd},
++ );
- add_bug_log($node,$bug_num);
+++$gSpoolDir = $options{spool} if defined $options{spool};
++
++if ($options{cron}) {
++ my %timestamps;
++ my $start_time = time;
++ my $unlink = 0;
++ my %seen_dirs;
++ check_pid($options{timestamp});
++ # read timestamp file
++ if (defined $options{timestamp}) {
++ my $timestamp_fh = new IO::File $options{timestamp},'r' or
++ die "Unable to open timestamp $options{timestamp}: $!";
++ while (<$timestamp_fh>) {
++ chomp;
++ my ($key,$value) = split /\s+/,$_,2;
++ $timestamps{$key} = $value;
++ }
++ }
++ for my $hash (map {sprintf '%02d',$_ } 0..99) {
++ find(sub {
++ print STDERR "Examining $_\n" if $DEBUG > 1;
++ return if not /^(\d+)\.log$/;
++ my $bug_num = $1;
++ my $stat = stat $_ or next;
++ return unless -f _;
++ return if exists $timestamps{$File::Find::dir} and
++ ($timestamps{$File::Find::dir} > $stat->mtime);
++ $seen_dirs{$File::Find::dir} = $start_time;
++ print STDERR "Adding $bug_num\n" if $DEBUG;
+++ my $max_message = 0;
++ eval{
+++ $max_message = add_bug_log($node,$bug_num);
++ };
++ if ($@) {
++ print STDERR "Adding $bug_num failed with $@\n";
++ }
++ },
++ map {(-d "$options{spool}/$_/$hash")?
++ "$options{spool}/$_/$hash":()}
++ qw(db-h archive),
++ );
++ # write timestamp file
++ if (defined $options{timestamp}) {
++ %timestamps = (%timestamps,%seen_dirs);
++ my $timestamp_fh = new IO::File $options{timestamp},'w' or
++ die "Unable to open timestamp $options{timestamp}: $!";
++ foreach my $key (keys %timestamps) {
++ print {$timestamp_fh} $key,' ',
++ $timestamps{$key}||'',qq(\n);
++ }
++ }
++ }
++ unlink("$options{timestamp}.pid");
++}
++else {
++ while (my $bug_num = <STDIN>) {
++ chomp $bug_num;
++ add_bug_log($node,$bug_num);
++ }
++}
++
++
++sub check_pid{
++ my ($timestamp) = @_;
++ if (-e "${timestamp}.pid") {
++ my $time_fh = new IO::File "${timestamp}.pid", 'r' or die "Unable to read pidfile";
++ local $/;
++ my $pid = <$time_fh>;
++ if (kill(0,$pid)) {
++ print STDERR "Another cron is running" and exit 0;
++ }
++ }
++ my $time_fh = new IO::File "${timestamp}.pid", 'w' or
++ die "Unable to read pidfile";
++ print {$time_fh} $$;
++}
++
++
++__END__
$lib_path = '/usr/lib/debbugs';
require "$lib_path/errorlib";
---use Debbugs::Packages;
+++use Debbugs::Packages qw(:versions :mapping);
use Debbugs::Versions;
use Debbugs::MIME qw(decode_rfc1522);
- use Debbugs::Common qw(:read :util);
+++use Debbugs::Common qw(:util);
+++use Debbugs::Status qw(:read :versions);
+++use Debbugs::CGI qw(:all);
+++
$MLDBM::RemoveTaint = 1;
return map lc, split /[ \t?,()]+/, $pkgs;
}
---my %_parsedaddrs;
---sub getparsedaddrs {
--- my $addr = shift;
--- return () unless defined $addr;
--- return @{$_parsedaddrs{$addr}} if exists $_parsedaddrs{$addr};
--- @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
--- return @{$_parsedaddrs{$addr}};
---}
---
# Generate a comma-separated list of HTML links to each package given in
# $pkgs. $pkgs may be empty, in which case an empty string is returned, or
# it may be a comma-separated list of package names.
sub htmlpackagelinks {
--- my $pkgs = shift;
--- return unless defined $pkgs and $pkgs ne '';
--- my $strong = shift;
--- my @pkglist = splitpackages($pkgs);
---
--- my $openstrong = $strong ? '<strong>' : '';
--- my $closestrong = $strong ? '</strong>' : '';
---
--- return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' .
--- join(', ',
--- map {
--- '<a href="' . pkgurl($_) . '">' .
--- $openstrong . htmlsanit($_) . $closestrong . '</a>'
--- } @pkglist
--- );
+++ return htmlize_packagelinks(@_);
}
# Generate a comma-separated list of HTML links to each address given in
# $urlfunc should be a reference to a function like mainturl or submitterurl
# which returns the URL for each individual address.
sub htmladdresslinks {
--- my ($prefixfunc, $urlfunc, $addresses) = @_;
--- if (defined $addresses and $addresses ne '') {
--- my @addrs = getparsedaddrs($addresses);
--- my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs)
--- : $prefixfunc;
--- return $prefix .
--- join ', ', map { sprintf '<a href="%s">%s</a>',
--- $urlfunc->($_->address),
--- htmlsanit($_->format) || '(unknown)'
--- } @addrs;
--- } else {
--- my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc;
--- return sprintf '%s<a href="%s">(unknown)</a>', $prefix, $urlfunc->('');
--- }
+++ htmlize_addresslinks(@_);
}
# Generate a comma-separated list of HTML links to each maintainer given in
. htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
. "</strong>"
if (length($status{tags}));
---
my @merged= split(/ /,$status{mergedwith});
my $mseparator= ";\nmerged with ";
for my $m (@merged) {
return $args;
}
---sub submitterurl { pkg_etc_url(emailfromrfc822($_[0] || ""), "submitter"); }
---sub mainturl { pkg_etc_url(emailfromrfc822($_[0] || ""), "maint"); }
---sub pkgurl { pkg_etc_url($_[0] || "", "pkg"); }
---sub srcurl { pkg_etc_url($_[0] || "", "src"); }
---sub tagurl { pkg_etc_url($_[0] || "", "tag"); }
+++sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0] || "")); }
+++sub mainturl { pkg_url(maint => emailfromrfc822($_[0] || "")); }
+++sub pkgurl { pkg_url(pkg => $_[0] || ""); }
+++sub srcurl { pkg_url(src => $_[0] || ""); }
+++sub tagurl { pkg_url(tag => $_[0] || ""); }
sub pkg_etc_url {
my $ref = shift;
return $in;
}
---sub maybelink {
--- my $in = shift;
--- if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
--- return qq{<a href="$in">} . htmlsanit($in) . '</a>';
--- } else {
--- return htmlsanit($in);
--- }
---}
---
sub bugurl {
my $ref = shift;
my $params = "bug=$ref";
return $tree->buggy($ver, \@found, \@fixed);
}
---my %_versions;
---sub getversions {
--- my ($pkg, $dist, $arch) = @_;
--- return () unless defined $debbugs::gVersionIndex;
--- $dist = 'unstable' unless defined $dist;
---
--- unless (tied %_versions) {
--- tie %_versions, 'MLDBM', $debbugs::gVersionIndex, O_RDONLY
--- or die "can't open versions index: $!";
--- }
---
--- if (defined $arch and exists $_versions{$pkg}{$dist}{$arch}) {
--- my $ver = $_versions{$pkg}{$dist}{$arch};
--- return $ver if defined $ver;
--- return ();
--- } else {
--- my %uniq;
--- for my $ar (keys %{$_versions{$pkg}{$dist}}) {
--- $uniq{$_versions{$pkg}{$dist}{$ar}} = 1 unless $ar eq 'source';
--- }
--- if (%uniq) {
--- return keys %uniq;
--- } elsif (exists $_versions{$pkg}{$dist}{source}) {
--- # Maybe this is actually a source package with no corresponding
--- # binaries?
--- return $_versions{$pkg}{$dist}{source};
--- } else {
--- return ();
--- }
--- }
---}
sub getversiondesc {
my $pkg = shift;
require '/etc/debbugs/text';
use Debbugs::User;
+++use Debbugs::CGI qw(version_url);
use vars qw($gPackagePages $gWebDomain %gSeverityDisplay @gSeverityList);
"pri" => [map { "severity=$_" } @debbugs::gSeverityList],
"ttl" => [map { $debbugs::gSeverityDisplay{$_} } @debbugs::gSeverityList],
"def" => "Unknown Severity",
--- "ord" => [0,1,2,3,4,5,6,7],
+++ "ord" => [0..@debbugs::gSeverityList],
} ],
"classification" => [ {
"nam" => "Classification",
my %indexentry;
my %strings = ();
---$ENV{"TZ"} = 'UTC';
---tzset();
---
---my $dtime = strftime "%a, %e %b %Y %T UTC", localtime;
+++my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
my $tail_html = $debbugs::gHTMLTail;
$tail_html = $debbugs::gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
s{/}{ } foreach @fixed;
$showversions .= join ', ', map htmlsanit($_), @fixed;
}
--- $result .= " ($showversions)" if length $showversions;
+++ $result .= ' (<a href="'.
+++ version_url($status{package},
+++ $status{found_versions},
+++ $status{fixed_versions},
+++ ).qq{">$showversions</a>)} if length $showversions;
$result .= ";\n";
$result .= $showseverity;
unless (length($status{done})) {
if (length($status{forwarded})) {
$result .= ";\n<strong>Forwarded</strong> to "
- . maybelink($status{forwarded});
+ . join(', ',
+ map {maybelink($_)}
-- split /,\s*/,$status{forwarded}
+++ split /[,\s]+/,$status{forwarded}
+ );
}
my $daysold = int((time - $status{date}) / 86400); # seconds to days
if ($daysold >= 7) {
}
sub pkg_htmladdresslinks {
--- my ($prefixfunc, $urlfunc, $addresses) = @_;
--- if (defined $addresses and $addresses ne '') {
--- my @addrs = getparsedaddrs($addresses);
--- my $prefix = (ref $prefixfunc) ? $prefixfunc->(scalar @addrs)
--- : $prefixfunc;
--- return $prefix .
--- join ', ', map { sprintf '<a class="submitter" href="%s">%s</a>',
--- $urlfunc->($_->address),
--- htmlsanit($_->format) || '(unknown)'
--- } @addrs;
--- } else {
--- my $prefix = (ref $prefixfunc) ? $prefixfunc->(1) : $prefixfunc;
--- return sprintf '%s<a class="submitter" href="%s">(unknown)</a>', $prefix, $urlfunc->('');
--- }
+++ htmlize_addresslinks(@_,'submitter');
}
sub pkg_javascript {
<!--
function pagemain() {
toggle(1);
- toggle(2);
++ // toggle(2);
enable(1);
}
sub buglinklist {
my ($prefix, $infix, @els) = @_;
--- my $sep = $prefix;
--- my $r = "";
--- for my $e (@els) {
--- $r .= $sep."<A class=\"submitter\" href=\"" . bugurl($e) . "\">#$e</A>";
--- $sep = $infix;
--- }
--- return $r;
+++ return '' if not @els;
+++ return $prefix . bug_linklist($infix,'submitter',@els);
}
--- /dev/null
--- /dev/null
- -> dispatch_to('Debbugs::SOAP::Usertag')
++#!/usr/bin/perl -wT
++
++package debbugs;
++
++use SOAP::Transport::HTTP;
++
++use Debbugs::SOAP::Usertag;
+++use Debbugs::SOAP::Status;
++
++SOAP::Transport::HTTP::CGI
+++ -> dispatch_to('Debbugs::SOAP::Usertag', 'Debbugs::SOAP::Status')
++ -> handle;
++
- Don't lc owner or forwarded at submit time (closes: #288384)
- Explain how to close bugs in the ack message (closes: #37605)
- Make the moreinfo ack more general (closes: #70810)
- - Add SOAP support (closes: #377520) Thanks to Raphael Hertzog.
- Use RFC compliant dates in headers (closes: #362935)
+++ - Add SOAP support (closes: #377520) Thanks to Raphael Hertzog.
+ - Split forwarded on commas for linking (closes: #367813)
+ - Don't display duplicate bugs (closes: #348116)
+ - Display links to archived bugs for all searches (closes: #53710)
+ - Link to blocked bugs in the bugreport.cgi output (closes: #326077)
+ - Don't ask for more bugs if there is no maintainer (closes: #355190)
+ - Stop refering to developers on the index page (closes: #355786)
+ - Change control@ stop regex and documentation to match eachother
+ (closes: #366093)
++ - Make it obvious when commands to control have failed
++ (closes: #344184)
++ - Fix javascript error in pkgreport.cgi (closes: #346043)
++ - When a bug can't be found in control@; indicate to user that it may
++ be archived. (closes: #153536)
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
+++# -*- mode: cperl -*-
# This is the template debbugs configuration file.
# You *must* edit it in order for debbugs to work.
# $Id: config.in,v 1.23 2005/07/17 19:07:01 cjwatson Exp $
$gPseudoDescFile = "$gConfigDir/pseudo-packages.description";
$gPackageSource = "$gConfigDir/indices/sources";
+++
+++# Estraier Configuration
+++%gSearchEstraier = (url => 'http://localhost:1978/node/bts1',
+++ user => 'user',
+++ pass => 'pass',
+++ );
+++
1;
--- /dev/null
- system('touch','-d',"1/1/1970 + ${start_time}secs","$indexdest/by-$i$suffix.idx");
+ #!/usr/bin/perl
+
+ # Generates by-*.idx files for the CGI scripts
+ # Copyright (c) 2005/08/03 Anthony Towns
+ # GPL v2
+
+ #use strict;
+
+ use DB_File;
+ use MLDBM qw(DB_FILE Storable);
+ use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
+ use File::Copy;
+
+ use Getopt::Long;
+ use Pod::Usage;
+
+ use warnings;
+ use strict;
+
+ use File::stat;
+ use List::Util qw(min);
+
+ =head1 NAME
+
+ gen-indices - Generates index files for the cgi scripts
+
+ =head1 SYNOPSIS
+
+ gen-indices [options]
+
+ Options:
+ --index-path path to index location
+ --quick update changed bugs
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+ =head1 OPTIONS
+
+ =over
+
+ =itme B<--quick>
+
+ Only update changed bugs
+
+ =item B<--debug, -d>
+
+ Debug verbosity. (Default 0)
+
+ =item B<--help, -h>
+
+ Display brief useage information.
+
+ =item B<--man, -m>
+
+ Display this manual.
+
+ =back
+
+ =head1 EXAMPLES
+
+
+ =cut
+
++ # Use portable Storable images
++ $MLDBM::DumpMeth=q(portable);
++
+
+ my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ quick => 0,
+ index_path => undef,
+ );
+
+ GetOptions(\%options,'quick!','index_path|index-path=s','debug|d+','help|h|?','man|m') or pod2usage(2);
+ pod2usage(1) if $options{help};
+ pod2usage(-verbose=>2) if $options{man};
+
+ { no warnings;
+ no strict;
+ require '/etc/debbugs/config';
+ require '/org/bugs.debian.org/scripts/errorlib';
+ }
+
+ chdir('/org/bugs.debian.org/spool') or die "chdir spool: $!\n";
+
+ my $verbose = $options{debug};
+ my $indexdest = $options{index_path} || "/org/bugs.debian.org/spool";
+
+ my $initialdir = "db-h";
+ my $suffix = "";
+
+ if (defined $ARGV[0] and $ARGV[0] eq "archive") {
+ $initialdir = "archive";
+ $suffix = "-arc";
+ }
+
+ # NB: The reverse index is special; it's used to clean up during updates to bugs
+ my @indexes = ('package', 'tag', 'severity', 'submitter-email','reverse');
+ my $indexes;
+ my %slow_index = ();
+ my %fast_index = ();
+ if (not $options{quick}) {
+ # We'll trade memory for speed here if we're not doing a quick rebuild
+ for my $indexes (@indexes) {
+ $fast_index{$indexes} = {};
+ }
+ $indexes = \%fast_index;
+ }
+ else {
+ $indexes = \%slow_index;
+ }
+ my $time = undef;
+ my $start_time = time;
+ for my $i (@indexes) {
+ $slow_index{$i} = {};
+ if ($options{quick}) {
+ if (-e "$indexdest/by-$i${suffix}.idx") {
+ system('cp','-a',"$indexdest/by-$i${suffix}.idx","$indexdest/by-$i${suffix}.idx.new") == 0
+ or die "Error creating the new index";
+ my $stat = stat("$indexdest/by-$i${suffix}.idx") or die "Unable to stat $indexdest/by-$i${suffix}.idx";
+ $time = defined $time ? min($time,$stat->mtime) : $stat->mtime;
+ }
+ tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
+ O_RDWR|O_CREAT, 0666
+ or die "$0: can't create by-$i$suffix-idx.new: $!";
+ }
+ else {
+ tie %{$slow_index{$i}}, MLDBM => "$indexdest/by-$i$suffix.idx.new",
+ O_RDWR|O_CREAT|O_TRUNC, 0666
+ or die "$0: can't create by-$i$suffix-idx.new: $!";
+
+ }
+ $time = 0 if not defined $time;
+ }
+
+ sub addbugtoindex {
+ my ($index, $bug, @values) = @_;
+
+ if (exists $indexes->{reverse}{"$index $bug"}) {
+ # We do this insanity to work around a "feature" in MLDBM
+ for my $key (@{$indexes->{reverse}{"$index $bug"}}) {
+ my $temp = $indexes->{$index}{$key};
+ delete $temp->{$bug};
+ $indexes->{$index}{$key} = $temp;
+ $indexes->{$index}{"count $key"}--;
+ }
+ delete $indexes->{reverse}{"$index $bug"};
+ }
+ for my $key (@values) {
+ $indexes->{$index}->{"count $key"}++;
+ # We do this insanity to work around a "feature" in MLDBM
+ my $temp = $indexes->{$index}->{$key};
+ $temp->{$bug} = 1;
+ $indexes->{$index}->{$key} = $temp;
+ }
+ $indexes->{reverse}{"$index $bug"} = [@values];
+ }
+
+ sub emailfromrfc822 {
+ my $email = shift;
+ $email =~ s/\s*\(.*\)\s*//;
+ $email = $1 if ($email =~ m/<(.*)>/);
+ return $email;
+ }
+
+ my $cnt = 0;
+
+ my @dirs = ($initialdir);
+ while (my $dir = shift @dirs) {
+ printf "Doing dir %s ...\n", $dir if $verbose;
+
+ opendir(DIR, "$dir/.") or die "opendir $dir: $!\n";
+ my @subdirs = readdir(DIR);
+ closedir(DIR);
+
+ my @list = map { m/^(\d+)\.summary$/?($1):() } @subdirs;
+ push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
+
+ for my $bug (@list) {
+ print "Up to $cnt bugs...\n" if (++$cnt % 100 == 0 && $verbose);
+ my $stat = stat(getbugcomponent($bug,'summary'));
+ next if $stat->mtime < $time;
+ my $fdata = readbug($bug, $initialdir);
+ addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
+ addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
+ addbugtoindex('submitter-email', $bug,
+ emailfromrfc822($fdata->{"originator"}));
+ addbugtoindex("severity", $bug, $fdata->{"severity"});
+ }
+ }
+
+ if (not $options{quick}) {
+ # put the fast index into the slow index
+ for my $key1 (keys %fast_index) {
+ for my $key2 (keys %{$fast_index{$key1}}) {
+ $slow_index{$key1}{$key2} = $fast_index{$key1}{$key2};
+ }
+ print "Dealt with index $key1\n" if $verbose;
+ }
+ }
+
+
+ for my $i (@indexes) {
+ untie %{$slow_index{$i}};
+ move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
++ # We do this, because old versions of touch don't support -d '@epoch'
++ system('touch','-d',"1/1/1970 UTC + ${start_time}secs","$indexdest/by-$i$suffix.idx");
+ }
+++
---# $Id: text.in,v 1.23 2003/09/18 11:20:54 joy Exp $
++# -*- mode: cperl -*-
++
++use Debbugs::Config qw(:globals);
############################################################################
# Here is a blurb to point people to ftp archive of directions. It is
projects / debbugs.git / commitdiff