--- /dev/null
+
+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 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
+
+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 = ();
+ %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 = ();
+ 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;
+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";
+ my ($u);
while ($u= $cleanups[$#cleanups]) { &$u; }
die "*** $_[0]\n";
}
-sub sani
-{
- HTML::Entities::encode($a);
-}
+
+
+
+
1;
-END { } # module clean-up code here (global destructor)
+
+__END__
-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',':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
+
+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__
+
+
+
+
+
+
package Debbugs::Packages;
+use warnings;
use strict;
-# TODO: move config handling to a separate module
-my $config_path = '/etc/debbugs';
-require "$config_path/config";
-# Allow other modules to load config into their namespace.
-delete $INC{"$config_path/config"};
+use Debbugs::Config qw(:config :globals);
-use Exporter ();
-use vars qw($VERSION @ISA @EXPORT);
+use base qw(Exporter);
+use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
BEGIN {
$VERSION = 1.00;
- @ISA = qw(Exporter);
- @EXPORT = qw(getpkgsrc getpkgcomponent getsrcpkgs
- binarytosource sourcetobinary);
+ @EXPORT = ();
+ %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);
-use MLDBM qw(DB_File);
+use MLDBM qw(DB_File Storable);
$MLDBM::RemoveTaint = 1;
my %pkgcomponent;
open(MM,"$Debbugs::Packages::gPackageSource")
- or &quitcgi("open $Debbugs::Packages::gPackageSource: $!");
+ or die("open $Debbugs::Packages::gPackageSource: $!");
while(<MM>) {
next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/;
my ($bin,$cmp,$src)=($1,$2,$3);
return map [$_, $srcver], @srcpkgs;
}
+=item getversions
+
+Returns versions of the package in distribution at a specific architecture
+
+=cut
+
+my %_versions;
+sub getversions {
+ my ($pkg, $dist, $arch) = @_;
+ return () unless defined $gVersionIndex;
+ $dist = 'unstable' unless defined $dist;
+
+ unless (tied %_versions) {
+ tie %_versions, 'MLDBM', $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 ();
+ }
+ }
+}
+
+
+
=back
=cut
--- /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
+package Debbugs::SOAP::Usertag;
+
+use Debbugs::User;
+
+sub get_usertag {
+ my ($class, $email, $tag) = @_;
+ my %ut = ();
+ Debbugs::User::read_usertags(\%ut, $email);
+ if (defined($tag) and $tag ne "") {
+ # Remove unwanted tags
+ foreach (keys %ut) {
+ delete $ut{$_} unless $_ eq $tag;
+ }
+ }
+ return \%ut;
+}
+
+1;
--- /dev/null
+
+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 = ();
+ %EXPORT_TAGS = (status => [qw(splitpackages)],
+ read => [qw(readbug lockreadbug)],
+ write => [qw(writebug makestatus unlockwritebug)],
+ versions => [qw(addfoundversion addfixedversion),
+ ],
+ );
+ @EXPORT_OK = ();
+ 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)) {
+ @{$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 {
+ 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)) {
+ 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") {
+ 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(
+ "$config{spool_dir}/index.db.realtime",
+ $ref,
+ "REMOVE");
+ 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";
+ 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__
--- /dev/null
+package Debbugs::URI;
+
+=head1 NAME
+
+Debbugs::URI -- Derivative of URI which overrides the query_param
+ method to use ';' instead of '&' for separators.
+
+=head1 SYNOPSIS
+
+use Debbugs::URI;
+
+=head1 DESCRIPTION
+
+See L<URI> for more information.
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+use warnings;
+use strict;
+use base qw(URI URI::_query);
+
+=head2 query_param
+
+ $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
+
+Exactly like query_param in L<URI> except query elements are joined by
+; instead of &.
+
+=cut
+
+{
+
+ package URI::_query;
+
+ no warnings 'redefine';
+ # Handle ...?foo=bar&bar=foo type of query
+ sub URI::_query::query_form {
+ my $self = shift;
+ my $old = $self->query;
+ if (@_) {
+ # Try to set query string
+ my @new = @_;
+ if (@new == 1) {
+ my $n = $new[0];
+ if (ref($n) eq "ARRAY") {
+ @new = @$n;
+ }
+ elsif (ref($n) eq "HASH") {
+ @new = %$n;
+ }
+ }
+ my @query;
+ while (my($key,$vals) = splice(@new, 0, 2)) {
+ $key = '' unless defined $key;
+ $key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
+ $key =~ s/ /+/g;
+ $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
+ for my $val (@$vals) {
+ $val = '' unless defined $val;
+ $val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g;
+ $val =~ s/ /+/g;
+ push(@query, "$key=$val");
+ }
+ }
+ # We've changed & to a ; here.
+ $self->query(@query ? join(';', @query) : undef);
+ }
+ return if !defined($old) || !length($old) || !defined(wantarray);
+ return unless $old =~ /=/; # not a form
+ map { s/\+/ /g; uri_unescape($_) }
+ # We've also changed the split here to split on ; as well as &
+ map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
+ }
+}
+
+
+
+
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
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 = ();
- @EXPORT_OK = qw(is_valid_user open);
+ @EXPORT_OK = qw(is_valid_user open read_usertags write_usertags);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
-my $gSpoolPath = "/org/bugs.debian.org/spool";
-
# Obsolete compatability functions
sub read_usertags {
sub filefromemail {
my $e = shift;
my $l = length($e) % 7;
- return "$gSpoolPath/user/$l/" . join("",
+ return "$gSpoolDir/user/$l/" . join("",
map { m/^[0-9a-zA-Z_+.-]$/ ? $_ : sprintf("%%%02X", ord($_)) }
split //, $e);
}
--- /dev/null
+#!/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},
+ );
+$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__
--- /dev/null
+#!/usr/bin/perl
+# test_bts tests a running BTS by sending mail to it, 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
+
+test_bts - Test a running bts install
+
+=head1 SYNOPSIS
+
+test_bts [options]
+
+ Options:
+ --bug, -b bug number to mail
+ --host, -h host to send mail to
+ --control, -c whether to send control messages (off by default)
+ --process, -p whether to send process messages (on by default)
+ --submit, -s whether a new bug is created (off by default)
+ --quiet, -q disable output (off by default)
+ --debug, -d debugging level (Default 0)
+ --help, -h display this help
+ --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--bug, -b>
+
+Bug number to mail
+
+=item B<--host, -H>
+
+The host running the bts
+
+=item B<--control, -c>
+
+Whether control messages are sent; defaults to false.
+
+=item B<--process, -p>
+
+Whether messages are sent to process (bugnum@host)
+
+=item B<--submit, -s>
+
+Whether a new bug is created by a message to submit; not enabled by default.
+
+=item B<--quiet,-q>
+
+Disable output
+
+=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::Mail qw(send_mail_message);
+use Debbugs::MIME qw(create_mime_message);
+
+
+use vars qw($DEBUG $VERBOSE);
+
+# XXX parse config file
+
+my %options = (debug => 0,
+ help => 0,
+ man => 0,
+ host => undef,
+ bug => undef,
+ quiet => 0,
+ from => undef,
+ process => 1,
+ submit => 0,
+ control => 0,
+ );
+
+GetOptions(\%options,'host|H=s','bug|b=s','control|c!','submit|s!',
+ 'process|p!','from|f=s','quiet|q+',
+ 'debug|d+','help|h|?','man|m');
+
+my $ERRORS = '';
+
+$ERRORS .= "--from must be set\n" if not defined $options{from};
+$ERRORS .= "--host must be set\n" if not defined $options{host};
+$ERRORS .= "--bug must be set\n" if not defined $options{bug};
+pod2usage($ERRORS) if length $ERRORS;
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+
+$DEBUG = $options{debug};
+
+$VERBOSE = 1 - $options{quiet};
+
+if ($options{process}) {
+ my @standard_headers = ([],
+ ['X-Debbugs-No-Ack:','yes no ack'],
+ );
+
+ my %process_messages = ('-maintonly' => \@standard_headers,
+ '-quiet' => \@standard_headers,
+ '-forwarded' => \@standard_headers,
+ '-done' => \@standard_headers,
+ '-submitter' => \@standard_headers,
+ '' => \@standard_headers,
+ );
+ my $message_count = 0;
+ for my $addr (keys %process_messages) {
+ for my $header (@{$process_messages{$addr}}) {
+ $message_count++;
+ my $message =
+ create_mime_message([To => "$options{bug}$addr\@$options{host}",
+ From => $options{from},
+ Subject => "message $message_count to $addr from test_bts",
+ @{$header},
+ ],<<END
+This is a testing message from test_bts
+This message was sent:
+To: $options{bug}$addr\@$options{host}
+From: $options{from}
+Subject: message $message_count to $options{bug}$addr\@$options{host} from test_bts
+
+with additional headers:
+@{$header}
+
+If you are seeing this, and have no idea what this means, please
+ignore this message. If you are sure that this message has been sent
+in error please send mail to $options{from} so they can stop sending
+stupid messages to you.
+
+If you are reading this message in a BTS, it's only a testing message.
+Please ignore it... it shouldn't have been sent to a public one, but
+accidents happen.
+END
+ );
+ send_mail_message(message => $message,
+ recipients => "$options{bug}$addr\@$options{host}",
+ );
+ }
+ }
+}
+if ($options{control}) {
+ die "Not implemented";
+}
+if ($options{submit}) {
+ die "Not implemented";
+}
+
+__END__
package debbugs;
+use warnings;
use strict;
use POSIX qw(strftime tzset);
use MIME::Parser;
use IO::Scalar;
use IO::File;
+use Debbugs::Config qw(:globals);
#require '/usr/lib/debbugs/errorlib';
require './common.pl';
-require '/etc/debbugs/config';
require '/etc/debbugs/text';
-use vars(qw($gEmailDomain $gHTMLTail $gSpoolDir $gWebDomain));
-
# for read_log_records
use Debbugs::Log;
-use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522);
+use Debbugs::MIME qw(convert_to_utf8 decode_rfc1522 create_mime_message);
+use Debbugs::CGI qw(:url :html);
use Scalar::Util qw(looks_like_number);
my $trim_headers = ($param{trim} || ($msg?'no':'yes')) eq 'yes';
+my $mbox_status_message = ($param{mboxstat}||'no') eq 'yes';
+my $mbox_maint = ($param{mboxmaint}||'no') eq 'yes';
+$mbox = 1 if $mbox_status_message or $mbox_maint;
+
+
# Not used by this script directly, but fetch these so that pkgurl() and
# friends can propagate them correctly.
my $archive = ($param{'archive'} || 'no') eq 'yes';
my $tpack;
my $tmain;
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-my $dtime = strftime "%a, %e %b %Y %T UTC", localtime;
+my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
$tail_html = $debbugs::gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
}
-=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.
-
-=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="'.bugurl($bug,'').qq(">$bug</a>);
- }
- return join(', ',@output);
-}
-
=head2 handle_record
push @log, handle_record($record,$ref,$msg_num);
}
my @log;
if ( $mbox ) {
+ my $date = strftime "%a %b %d %T %Y", localtime;
if (@records > 1) {
print qq(Content-Disposition: attachment; filename="bug_${ref}.mbox"\n);
print "Content-Type: text/plain\n\n";
print qq(Content-Disposition: attachment; filename="bug_${ref}_message_${msg_num}.mbox"\n);
print "Content-Type: message/rfc822\n\n";
}
+ if ($mbox_status_message and @records > 1) {
+ my $status_message='';
+ my @status_fields = (retitle => 'subject',
+ package => 'package',
+ submitter => 'originator',
+ severity => 'severity',
+ tag => 'tags',
+ owner => 'owner',
+ blocks => 'blocks',
+ forward => 'forward',
+ );
+ my ($key,$value);
+ while (($key,$value) = splice(@status_fields,0,2)) {
+ if (defined $status{$value} and length $status{$value}) {
+ $status_message .= qq($key $ref $status{$value}\n);
+ }
+ }
+ print STDOUT qq(From unknown $date\n),
+ create_mime_message([From => "$debbugs::gBug#$ref <$ref\@$debbugs::gEmailDomain>",
+ To => "$debbugs::gBug#$ref <$ref\@$debbugs::gEmailDomain>",
+ Subject => "Status: $status{subject}",
+ "Reply-To" => "$debbugs::gBug#$ref <$ref\@$debbugs::gEmailDomain>",
+ ],
+ <<END,);
+$status_message
+thanks
+
+
+END
+ }
+ my $message_number=0;
+ my %seen_message_ids;
for my $record (@records) {
next if $record->{type} !~ /^(?:recips|incoming-recv)$/;
- next if not $boring and $record->{type} eq 'recips' and @records > 1;
+ my $wanted_type = $mbox_maint?'recips':'incoming-recv';
+ # we want to include control messages anyway
+ my $record_wanted_anyway = 0;
+ my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
+ next if exists $seen_message_ids{$msg_id};
+ $seen_message_ids{$msg_id} = 1;
+ next if $msg_id =~/handler\..+\.ack(?:info)?\@/;
+ $record_wanted_anyway = 1 if $record->{text} =~ /^Received: \(at control\)/;
+ next if not $boring and $record->{type} ne $wanted_type and not $record_wanted_anyway and @records > 1;
my @lines = split( "\n", $record->{text}, -1 );
if ( $lines[ 1 ] =~ m/^From / ) {
my $tmp = $lines[ 0 ];
$lines[ 1 ] = $tmp;
}
if ( !( $lines[ 0 ] =~ m/^From / ) ) {
- my $date = strftime "%a %b %d %T %Y", localtime;
unshift @lines, "From unknown $date";
}
map { s/^(>*From )/>$1/ } @lines[ 1 .. $#lines ];
print qq(<p><a href="mailto:$ref\@$debbugs::gEmailDomain">Reply</a> ),
qq(or <a href="mailto:$ref-subscribe\@$debbugs::gEmailDomain">subscribe</a> ),
qq(to this bug.</p>\n);
-printf "<div class=\"msgreceived\"><p>View this report as an <a href=\"%s\">mbox folder</a>.</p></div>\n", bugurl($ref, "mbox");
+printf qq(<div class="msgreceived"><p>View this report as an <a href="%s">mbox folder</a>, ).
+ qq(<a href="%s">status mbox</a>, <a href="%s">maintainer mbox</a></p></div>\n),
+ html_escape(bug_url($ref, mbox=>'yes')),
+ html_escape(bug_url($ref, mbox=>'yes',mboxstatus=>'yes')),
+ html_escape(bug_url($ref, mbox=>'yes',mboxmaint=>'yes'));
print "<HR>";
print "$log";
print "<HR>";
$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(: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;
my $days = 0;
if (length($status{done})) {
$result .= "<br><strong>Done:</strong> " . htmlsanit($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>";
- }
+# Disabled until archiving actually works again
+# $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>";
+# }
}
unless (length($status{done})) {
$result .= ";\n<strong>Forwarded</strong> to "
. join(', ',
map {maybelink($_)}
- split /,\s*/,$status{forwarded}
+ split /[,\s]+/,$status{forwarded}
);
}
my $daysold = int((time - $status{date}) / 86400); # seconds to days
}
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);
}
function toggle(i) {
var a = document.getElementById("a_" + i);
- if (a.style.display == "none") {
- a.style.display = "";
- } else {
- a.style.display = "none";
+ if (a) {
+ if (a.style.display == "none") {
+ a.style.display = "";
+ } else {
+ a.style.display = "none";
+ }
}
}
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
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+# Hack to work on merkel where suexec is in place
+BEGIN{
+ if ($ENV{HTTP_HOST} eq 'merkel.debian.org') {
+ unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source);
+ $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal";
+ }
+}
+
+
+use CGI::Simple;
+
+use CGI::Alert 'don@donarmstrong.com';
+
+use Search::Estraier;
+use Debbugs::Config qw(:config);
+use Debbugs::Estraier;
+use Debbugs::CGI qw(htmlize_packagelinks html_escape);
+use HTML::Entities qw(encode_entities);
+
+my $q = new CGI::Simple;
+
+#my %var_defaults = (attr => 1,);
+
+my %cgi_var = cgi_parameters($q);
+
+$cgi_var{phrase} = '' if not defined $cgi_var{phrase};
+$cgi_var{max_results} = 10 if not defined $cgi_var{max_results};
+$cgi_var{attribute} = parse_attribute(\%cgi_var) || [];
+$cgi_var{skip} = 0 if not defined $cgi_var{skip};
+
+my @results;
+
+if (defined $cgi_var{next}) {
+ $cgi_var{search} = 1;
+ $cgi_var{skip} += $cgi_var{max_results};
+}
+elsif (defined $cgi_var{prev}) {
+ $cgi_var{search} = 1;
+ $cgi_var{skip} -= $cgi_var{max_results};
+ $cgi_var{skip} = 0 if $cgi_var{skip} < 0;
+}
+
+my $nres;
+if (defined $cgi_var{search} and length $cgi_var{phrase}) {
+ # connect to a node if we need to
+ my $node = new Search::Estraier::Node (url => $config{search_estraier}{url},
+ user => $config{search_estraier}{user},
+ passwd => $config{search_estraier}{pass},
+ croak_on_error => 1,
+ ) or die "Unable to connect to the node";
+ my $cond = new Search::Estraier::Condition;
+ $cond->set_phrase($cgi_var{phrase});
+ if (defined $cgi_var{order_field} and length $cgi_var{order_field} and
+ defined $cgi_var{order_operator} and length $cgi_var{order_operator}) {
+ $cond->set_order($cgi_var{order_field}.' '.$cgi_var{order_operator});
+ }
+ foreach my $attribute (@{$cgi_var{attribute}}) {
+ if (defined $$attribute{field} and defined $$attribute{value} and
+ defined $$attribute{operator} and length $$attribute{value}) {
+ $cond->add_attr(join(' ',map {$$attribute{$_}} qw(field operator value)));
+ }
+ }
+ $cond->set_skip($cgi_var{skip}) if defined $cgi_var{skip} and $cgi_var{skip} =~ /(\d+)/;
+ $cond->set_max($cgi_var{max_results}) if defined $cgi_var{max_results} and $cgi_var{max_results} =~ /^\d+$/;
+ print STDERR "skip: ".$cond->skip()."\n";
+ print STDERR $node->cond_to_query($cond),qq(\n);
+ $nres = $node->search($cond,0) or
+ die "Unable to search for condition";
+
+}
+elsif (defined $cgi_var{add_attribute} and length $cgi_var{add_attribute}) {
+ push @{$cgi_var{attribute}}, {value => ''};
+}
+elsif (grep /^delete_attribute_\d+$/, keys %cgi_var) {
+ foreach my $delete_key (sort {$b <=> $a} map {/^delete_attribute_(\d+)$/?($1):()} keys %cgi_var) {
+ splice @{$cgi_var{attribute}},$delete_key,1;
+ }
+}
+
+my $url = 'http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=';
+
+print <<END;
+Content-Type: text/html
+
+
+<HTML><HEAD><TITLE>BTS Search</TITLE>
+<link rel="stylesheet" href="http://bugs.debian.org/css/bugs.css" type="text/css">
+</HEAD>
+<BODY>
+<FORM>
+<table class="forms">
+<tr><td>
+<p>Phrase: <input type="text" name="phrase" value="$cgi_var{phrase}" size="80" id="phrase" title="Input some words for full-text search" tabindex="1" accesskey="a" />
+<input type="submit" name="search" value="search" title="Perform the search" tabindex="8" accesskey="f" />
+<input type="hidden" name="skip" value="$cgi_var{skip}"></p>
+END
+
+# phrase
+# attributes
+# NUMEQ : is equal to the number or date
+# NUMNE : is not equal to the number or date
+# NUMGT : is greater than the number or date
+# NUMGE : is greater than or equal to the number or date
+# NUMLT : is less than the number or date
+# NUMLE : is less than or equal to the number or date
+# NUMBT : is between the two numbers or dates
+my @num_operators = (NUMEQ => 'equal to',
+ NUMNE => 'not equal to',
+ NUMGT => 'greater than',
+ NUMGE => 'greater than or equal to',
+ NUMLT => 'less than',
+ NUMLE => 'less than or equal to',
+ NUMBT => 'between',
+ );
+
+# STREQ : is equal to the string
+# STRNE : is not equal to the string
+# STRINC : includes the string
+# STRBW : begins with the string
+# STREW : ends with the string
+# STRAND : includes all tokens in the string
+# STROR : includes at least one token in the string
+# STROREQ : is equal to at least one token in the string
+# STRRX : matches regular expressions of the string
+my @str_operators = (STREQ => 'equal to',
+ STRNE => 'not equal to',
+ STRINC => 'includes',
+ STRBW => 'begins with',
+ STREW => 'ends with',
+ STRAND => 'includes all tokens',
+ STROR => 'includes at least one token',
+ STROREQ => 'is equal to at least one token',
+ STRRX => 'matches regular expression',
+ );
+
+my @attributes_order = ('@cdate','@title','@author',
+ qw(status subject date submitter package tags severity),
+ );
+my %attributes = ('@cdate' => {name => 'Date',
+ type => 'num',
+ },
+ '@title' => {name => 'Message subject',
+ type => 'str',
+ },
+ '@author' => {name => 'Author',
+ type => 'str',
+ },
+ status => {name => 'Status',
+ type => 'str',
+ },
+ subject => {name => 'Bug Title',
+ type => 'num',
+ },
+ date => {name => 'Submission date',
+ type => 'num',
+ },
+ submitter => {name => 'Bug Submitter',
+ type => 'str',
+ },
+ package => {name => 'Package',
+ type => 'str',
+ },
+ tags => {name => 'Tags',
+ type => 'str',
+ },
+ severity => {name => 'Severity',
+ type => 'str',
+ },
+ );
+my $attr_num = 0;
+print qq(<p>Attributes:</p>\n);
+for my $attribute (@{$cgi_var{attribute}}) {
+ print qq(<select name="attribute_field">\n);
+ foreach my $attr (keys %attributes) {
+ my $selected = (defined $$attribute{field} and $$attribute{field} eq $attr) ? ' selected' : '';
+ print qq(<option value="$attr"$selected>$attributes{$attr}{name}</option>\n);
+ }
+ print qq(</select>\n);
+ print qq(<select name="attribute_operator">\n);
+ my $operator;
+ my $name;
+ my @tmp_array = (@num_operators,@str_operators);
+ while (($operator,$name) = splice(@tmp_array,0,2)) {
+ my $type = $operator =~ /^NUM/ ? 'Number' : 'String';
+ my $selected = (defined $$attribute{operator} and $$attribute{operator} eq $operator) ? 'selected' : '';
+ print qq(<option value="$operator"$selected>$name ($type)</option>\n);
+ }
+ print qq(</select>\n);
+ $$attribute{value}='' if not defined $$attribute{value};
+ print qq(<input type="text" name="attribute_value" value="$$attribute{value}"><input type="submit" name="delete_attribute_$attr_num" value="Delete"><br/>\n);
+ $attr_num++;
+
+}
+print qq(<input type="submit" name="add_attribute" value="Add Attribute"><br/>);
+
+# order
+
+# STRA : ascending by string
+# STRD : descending by string
+# NUMA : ascending by number or date
+# NUMD : descending by number or date
+
+my @order_operators = (STRA => 'ascending (string)',
+ STRD => 'descending (string)',
+ NUMA => 'ascending (number or date)',
+ NUMD => 'descending (number or date)',
+ );
+
+print qq(<p>Order by: <select name="order_field">\n);
+print qq(<option value="">Default</option>);
+foreach my $attr (keys %attributes) {
+ my $selected = (defined $cgi_var{order_field} and $cgi_var{order_field} eq $attr) ? ' selected' : '';
+ print qq(<option value="$attr"$selected>$attributes{$attr}{name}</option>\n);
+}
+print qq(</select>\n);
+print qq(<select name="order_operator">\n);
+my $operator;
+my $name;
+my @tmp_array = (@order_operators);
+while (($operator,$name) = splice(@tmp_array,0,2)) {
+ my $selected = (defined $cgi_var{order_field} and $cgi_var{order_operator} eq $operator) ? ' selected' : '';
+ print qq(<option value="$operator"$selected>$name</option>\n);
+}
+print qq(</select></p>\n);
+
+# max results
+
+print qq(<p>Max results: <select name="max_results">\n);
+for my $max_results (qw(10 25 50 100 150 200)) {
+ my $selected = (defined $cgi_var{max_results} and $cgi_var{max_results} eq $max_results) ? ' selected' : '';
+ print qq(<option value="$max_results"$selected>$max_results</optiion>\n);
+}
+print qq(</select></p>\n);
+
+print qq(</tr></td></table>\n);
+
+
+
+if (defined $nres) {
+ print "<h2> Results</h2>\n";
+ my $hits = $nres->hits();
+ print "<p>Hits: ".$hits;
+ if (($cgi_var{skip} > 0)) {
+ print q(<input type="submit" name="prev" value="Prev">);
+ }
+ if ($hits > ($cgi_var{skip}+$cgi_var{max_results})) {
+ print q(<input type="submit" name="next" value="Next">);
+ }
+ print "</p>\n";
+ print qq(<ul class="msgreceived">\n);
+ for my $rdoc (map {$nres->get_doc($_)} 0.. ($nres->doc_num-1)) {
+ my ($bugnum,$msgnum) = split m#/#,$rdoc->attr('@uri');
+ my %attr = map {($_,$rdoc->attr($_))} $rdoc->attr_names;
+ # initialize any missing variables
+ for my $var ('@title','@author','@cdate','package','severity') {
+ $attr{$var} = '' if not defined $attr{$var};
+ }
+ my $showseverity;
+ $showseverity = "Severity: <em>$attr{severity}</em>;\n";
+ print <<END;
+<li><a href="$url${bugnum}#${msgnum}">#${bugnum}: $attr{'@title'}</a> @{[htmlize_packagelinks($attr{package})]}<br/>
+$showseverity<br/>
+Sent by: @{[encode_entities($attr{'@author'})]} at $attr{'@cdate'}<br/>
+END
+ # Deal with the snippet
+ # make the things that match bits of the phrase bold, the rest normal.
+ my $snippet_mod = html_escape($attr{snippet});
+ $snippet_mod =~ s/\n\n/ . . . /g;
+ for my $phrase_bits (split /\s+/,$cgi_var{phrase}) {
+ $snippet_mod =~ s{\n(\Q$phrase_bits\E)(?:\s+\Q$phrase_bits\E\n)}{'<b>'.$1.'</b>'}gei;
+ }
+ print "<p>$snippet_mod</p>\n";
+ }
+ print "</ul>\n<p>";
+ if (($cgi_var{skip} > 0)) {
+ print q(<input type="submit" name="prev" value="Prev">);
+ }
+ if ($hits > ($cgi_var{skip}+$cgi_var{max_results})) {
+ print q(<input type="submit" name="next" value="Next">);
+ }
+ print "</p>\n";
+
+}
+
+print "</form>\n";
+
+# This CGI should make an abstract method of displaying information
+# about specific bugs and their messages; the information should be
+# fairly similar to the way that pkgreport.cgi works, with the
+# addition of snippit information and links to ajavapureapi/overview-summary.html specific message
+# within the bug.
+
+# For now we'll brute force the display, but methods to display a bug
+# or a particular bug message should be made common between the two
+# setups
+
+
+sub parse_attribute {
+ my ($cgi_var) = @_;
+
+ my @attributes = ();
+ if (ref $$cgi_var{attribute_operator}) {
+ for my $elem (0 ... $#{$$cgi_var{attribute_operator}}) {
+ push @attributes,{map {($_,$$cgi_var{"attribute_$_"}[$elem]);} qw(value field operator)};
+ }
+ }
+ elsif (defined $$cgi_var{attribute_operator}) {
+ push @attributes,{map {($_,$$cgi_var{"attribute_$_"});} qw(value field operator)};
+ }
+ return \@attributes;
+}
+
+
+sub cgi_parameters {
+ my ($q) = @_;
+
+ my %param;
+ foreach my $paramname ($q->param) {
+ my @value = $q->param($paramname);
+ $param{$paramname} = @value > 1 ? [@value] : $value[0];
+ }
+ return %param;
+}
--- /dev/null
+#!/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;
+
--- /dev/null
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+# Hack to work on merkel where suexec is in place
+BEGIN{
+ if ($ENV{HTTP_HOST} eq 'merkel.debian.org') {
+ unshift @INC, qw(/home/don/perl/usr/share/perl5 /home/don/perl/usr/lib/perl5 /home/don/source);
+ $ENV{DEBBUGS_CONFIG_FILE}="/home/don/config_internal";
+ }
+}
+
+
+use CGI::Simple;
+
+use CGI::Alert 'don@donarmstrong.com';
+
+use Debbugs::Config qw(:config);
+use Debbugs::CGI qw(htmlize_packagelinks html_escape);
+use Debbugs::Versions;
+use Debbugs::Versions::Dpkg;
+use Debbugs::Packages qw(getversions);
+use HTML::Entities qw(encode_entities);
+use File::Temp qw(tempdir);
+use IO::File;
+use IO::Handle;
+
+
+
+my $q = new CGI::Simple;
+
+my %cgi_var = cgi_parameters($q);
+
+$cgi_var{package} = ['xterm'] if not defined $cgi_var{package};
+$cgi_var{found} = [] if not defined $cgi_var{found};
+$cgi_var{fixed} = [] if not defined $cgi_var{fixed};
+
+# we only care about one package
+$cgi_var{package} = $cgi_var{package}[0];
+
+# we want to first load the appropriate file,
+# then figure out which versions are there in which architectures,
+my %versions;
+my %version_to_dist;
+for my $dist (qw(oldstable stable testing unstable)) {
+ $versions{$dist} = [getversions($cgi_var{package},$dist)];
+ # make version_to_dist
+ foreach my $version (@{$versions{$dist}}){
+ push @{$version_to_dist{$version}}, $dist;
+ }
+}
+# then figure out which are affected.
+
+my $srchash = substr $cgi_var{package}, 0, 1;
+my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
+my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$cgi_var{package}", 'r';
+$version->load($version_fh);
+# Here, we need to generate a short version to full version map
+my %version_map;
+foreach my $key (keys %{$version->{parent}}) {
+ my ($short_version) = $key =~ m{/(.+)$};
+ next unless length $short_version;
+ # we let the first short version have presidence.
+ $version_map{$short_version} = $key if not exists $version_map{$short_version};
+}
+# Turn all short versions into long versions
+for my $found_fixed (qw(found fixed)) {
+ $cgi_var{$found_fixed} =
+ [
+ map {
+ if ($_ !~ m{/}) { # short version
+ ($version_map{$_});
+ }
+ else { # long version
+ ($_);
+ }
+ } @{$cgi_var{$found_fixed}}
+ ];
+}
+my %all_states = $version->allstates($cgi_var{found},$cgi_var{fixed});
+
+my $dot = "digraph G {\n";
+my %state = (found => ['fillcolor="salmon"',
+ 'style="filled"',
+ 'shape="diamond"',
+ ],
+ absent => ['fillcolor="grey"',
+ 'style="filled"',
+ ],
+ fixed => ['fillcolor="chartreuse"',
+ 'style="filled"',
+ 'shape="rect"',
+ ],
+ );
+foreach my $key (keys %all_states) {
+ my ($short_version) = $key =~ m{/(.+)$};
+ my @attributes = @{$state{$all_states{$key}}};
+ if (length $short_version and exists $version_to_dist{$short_version}) {
+ push @attributes, 'label="'.$key.'\n'."(".join(', ',@{$version_to_dist{$short_version}}).")\"";
+ }
+ my $node_attributes = qq("$key" [).join(',',@attributes).qq(]\n);
+ $dot .= $node_attributes;
+}
+foreach my $key (keys %{$version->{parent}}) {
+ $dot .= qq("$key").'->'.qq("$version->{parent}{$key}" [dir="back"])."\n" if defined $version->{parent}{$key};
+}
+$dot .= "}\n";
+
+my $temp_dir = tempdir(CLEANUP => 1);
+
+if (not defined $cgi_var{dot}) {
+ my $dot_fh = new IO::File "$temp_dir/temp.dot",'w' or
+ die "Unable to open $temp_dir/temp.dot for writing: $!";
+ print {$dot_fh} $dot or die "Unable to print output to the dot file: $!";
+ close $dot_fh or die "Unable to close the dot file: $!";
+ system('dot','-Tpng',"$temp_dir/temp.dot",'-o',"$temp_dir/temp.png") == 0
+ or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
+ my $png_fh = new IO::File "$temp_dir/temp.png", 'r' or
+ die "Unable to open $temp_dir/temp.png for reading: $!";
+ print "Content-Type: image/png\n\n";
+ print <$png_fh>;
+ close $png_fh;
+}
+else {
+ print "Content-Type: text\n\n";
+ print $dot;
+}
+
+sub cgi_parameters {
+ my ($q) = @_;
+
+ my %param;
+ foreach my $paramname ($q->param) {
+ $param{$paramname} = [$q->param($paramname)]
+ }
+ return %param;
+}
- Explain how to close bugs in the ack message (closes: #37605)
- Make the moreinfo ack more general (closes: #70810)
- 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)
- 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
Package: debbugs
Architecture: all
-Depends: perl5 | perl, exim4 | mail-transport-agent, libmailtools-perl, ed, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl
+Depends: perl5 | perl, exim4 | mail-transport-agent, libmailtools-perl, ed, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl
Recommends: httpd, links | lynx
Suggests: spamassassin (>= 3.0)
Description: The bug tracking system based on the active Debian BTS
RewriteRule ^/$ http://www.debian.org/Bugs/
RewriteRule ^/(robots\.txt|release-critical|apt-listbugs\.html)$ - [L]
# The following two redirect to up-to-date pages
- RewriteRule ^/[[:space:]]*#?([[:digit:]][[:digit:]][[:digit:]]+)$ /cgi-bin/bugreport.cgi?bug=$1 [L,R]
+ RewriteRule ^/[[:space:]]*#?([[:digit:]][[:digit:]][[:digit:]]+)([;&].+)?$ /cgi-bin/bugreport.cgi?bug=$1$2 [L,R,NE]
RewriteRule ^/([^/+]*)([+])([^/]*)$ "/$1%%{%}2B$3" [N]
RewriteRule ^/[Ff][Rr][Oo][Mm]:([^/]+\@.+)$ /cgi-bin/pkgreport.cgi?submitter=$1 [L,R,NE]
# Commented out, 'cuz aj says it will crash master. (old master)
# RewriteRule ^/[Ss][Ee][Vv][Ee][Rr][Ii][Tt][Yy]:([^/]+\@.+)$ /cgi-bin/pkgreport.cgi?severity=$1 [L,R]
RewriteRule ^/([^/]+\@.+)$ /cgi-bin/pkgreport.cgi?maint=$1 [L,R,NE]
- RewriteRule ^/mbox:([[:digit:]][[:digit:]][[:digit:]]+)$ /cgi-bin/bugreport.cgi?mbox=yes&bug=$1 [L,R,NE]
+ RewriteRule ^/mbox:([[:digit:]][[:digit:]][[:digit:]]+)([;&].+)?$ /cgi-bin/bugreport.cgi?mbox=yes&bug=$1$2 [L,R,NE]
RewriteRule ^/src:([^/]+)$ /cgi-bin/pkgreport.cgi?src=$1 [L,R,NE]
RewriteRule ^/severity:([^/]+)$ /cgi-bin/pkgreport.cgi?severity=$1 [L,R,NE]
RewriteRule ^/tag:([^/]+)$ /cgi-bin/pkgreport.cgi?tag=$1 [L,R,NE]
--- /dev/null
+Here are outlined some of the future directions for the debbugs
+codebase and things that should be done.
+
+PACKAGE CLEANUP
+
+* Stop doing the .in -> foo translation
+* Use ExtUtils::Makemaker instead of a custom makefile
+* More testing of modules so it's not so easy to break things
+
+
+GENERAL ORGANIZATIONAL CLEANUP
+
+* Modularization
+ * use of strict and warnings everywhere
+ * Split out errorlib and common.pl; stop requiring stuff
+ * Use CGI::Simple, URI, and Params::Validate instead of our own
+ versions
+
+* Configuration Module
+ * Allow for multiple debbugs configurations; easy overriding of values
+ * Possibly implemented using Config::General (maybe Config::Simple?)
+ with hack to allow for backwards compatibility
+ - The backwards compatibility hack is now fully implemented, a
+ decision on a configuration system just needs to be made.
+
+* Separation of Output forms from the code
+ * Use Text::Template to do this; it's simple, we don't lose
+ flexibility if we need it
+
+* Bring back all of the helper scripts into the bzr repository and
+ document the setup of Debian's bts
+
+FEATURES
+
+* Full text searching -- using Hyper Estraier (in progress on merkel)
+ * See Debbugs::Estraier
+
+* CGI Options enable/disable forms
+
+* Better display of bugs in bug lists
+ - Display subsidiary bugs: merged bugs, block bugs, etc.
+
+* Archiving [display of applicable bugs even if they are archived]
+
+BUG FIXING
+
+* ...
\ No newline at end of file
<a href="Developer.html#tags">developers' documentation</a>.
Separate multiple tags with commas, spaces, or both.
+<pre>
+User: <<var>username</var>>
+Usertags: <<var>usertags</var>>
+</pre>
+
+<p>Replace <<var>usertags</var>> with one or more usertags.
+Separate multiple tags with commas, spaces, or both. If you specify a
+username, that users tags will be set. Otherwise, the email address of
+the sender will be used as the username</p>
+
<h2>Not forwarding to the mailing list - minor $gBug reports</h2>
# Domains
$gEmailDomain = "bugs.debian.org";
$gListDomain = "lists.debian.org";
+$gWebHostBugDir = "";
$gWebDomain = "www.debian.org/Bugs";
$gHTMLSuffix = "";
$gPackagePages = "packages.debian.org";
+# -*- 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;
#domains
$gEmailDomain = "bugs.top.domain"; #bugs.debian.org
$gListDomain = "lists.top.domain"; #lists.debian.org
+$gWebHostBugDir = "";
$gWebDomain = "www.top.domain"; #www.debian.org/Bugs
$gCGIDomain = "cgi.top.domain"; #cgi.debian.org
use Mail::Address;
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages;
+use Debbugs::Packages qw(:all);
+use Debbugs::Common qw(:all);
+use Debbugs::Status qw(:all);
sub F_SETLK { 6; } sub F_WRLCK{ 1; }
$flockstruct= 'sslll'; # And there ought to be something for this too.
-sub get_hashname {
- return "" if ( $_[ 0 ] < 0 );
- return sprintf "%02d", $_[ 0 ] % 100;
-}
-
sub unlockreadbugmerge {
local ($rv) = @_;
&unfilelock if $rv >= 2;
return ( 2, $data );
}
-sub getbuglocation {
- my ( $bugnum, $ext ) = @_;
- my $archdir = sprintf "%02d", $bugnum % 100;
- return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
- return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
- return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
- return undef;
-}
-
-sub getlocationpath {
- my ($location) = @_;
- if ($location eq 'archive') {
- return "$gSpoolDir/archive";
- } elsif ($location eq 'db') {
- return "$gSpoolDir/db";
- } else {
- return "$gSpoolDir/db-h";
- }
-}
-
-sub getbugcomponent {
- my ($bugnum, $ext, $location) = @_;
-
- unless (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 unless $dir;
- if ($location eq 'db') {
- return "$dir/$bugnum.$ext";
- } else {
- my $hash = get_hashname($bugnum);
- return "$dir/$hash/$bugnum.$ext";
- }
-}
-
-my @v1fieldorder = qw(originator date subject msgid package
- keywords done forwarded mergedwith severity);
-
-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',
- fixed_versions => 'fixed-in',
- 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);
-
-sub readbug {
- my ($lref, $location) = @_;
- my $status = getbugcomponent($lref, 'summary', $location);
- return undef unless defined $status;
- if (!open(S,$status)) { return undef; }
-
- my %data;
- my @lines;
- my $version = 2;
- local $_;
-
- while (<S>) {
- 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};
- }
-
- close(S);
-
- $data{severity} = $gDefaultSeverity if $data{severity} eq '';
- $data{found_versions} = [split ' ', $data{found_versions}];
- $data{fixed_versions} = [split ' ', $data{fixed_versions}];
-
- if ($version < 3) {
- for my $field (@rfc1522_fields) {
- $data{$field} = decode_rfc1522($data{$field});
- }
- }
-
- return \%data;
-}
-
-sub lockreadbug {
- local ($lref, $location) = @_;
- &filelock("lock/$lref");
- my $data = readbug($lref, $location);
- &unfilelock unless defined $data;
- return $data;
-}
-
-sub makestatus {
- my $data = shift;
- my $version = shift;
- $version = 2 unless defined $version;
-
- local $data->{found_versions} = join ' ', @{$data->{found_versions}};
- local $data->{fixed_versions} = join ' ', @{$data->{fixed_versions}};
-
- my $contents = '';
-
- my %newdata = %$data;
- 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;
-}
-
-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;
-}
-
-sub unlockwritebug {
- writebug(@_);
- &unfilelock;
-}
-
-sub filelock {
- # NB - NOT COMPATIBLE WITH `with-lock'
- local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
- $flockpushno= $#filelocks+1;
- $count= 10; $errors= '';
- for (;;) {
- $evalstring= "
- open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
- \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
- ($] >= 5.000 ? "
- fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
- \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
- && die \"syscall fcntl setlk: \$!\";") ."
- (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
- (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
- join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
- 1;
- ";
- last if eval $evalstring;
- $errors .= $@;
- eval "close(FLOCK$flockpushno);";
- if (--$count <=0) {
- $errors =~ s/\n+$//;
- &quit("failed to get lock on file $lockfile: $errors // $evalstring");
- }
- sleep 10;
- }
- push(@cleanups,'unfilelock');
- push(@filelocks,$lockfile);
-}
-
-sub unfilelock {
- if (@filelocks == 0) {
- warn "unfilelock called with no active filelocks!\n";
- return;
- }
- local ($lockfile) = pop(@filelocks);
- pop(@cleanups);
- eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
- unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
-}
-
-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}};
- }
-}
-
-sub quit {
- print DEBUG "quitting >$_[0]<\n";
- local ($u);
- while ($u= $cleanups[$#cleanups]) { &$u; }
- die "*** $_[0]\n";
-}
-
%saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
sub sani {
- local ($in) = @_;
- local ($out);
- while ($in =~ m/[<>&"]/) {
- $out.= $`. '&'. $saniarray{$&}. ';';
- $in=$';
- }
- $out.= $in;
- $out;
-}
-
-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") {
- print IDXNEW $line if ($line ne "" && $line[1] == $ref);
- } 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(
- "$gSpoolDir/index.db.realtime",
- $ref,
- "REMOVE");
- update_realtime("$gSpoolDir/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";
- my $severity = $gDefaultSeverity;
- (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("$gSpoolDir/index.db.realtime", $ref, $k);
-
- &unfilelock;
-}
-
-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): $!");
+ my ($in) = @_;
+ warn "You should be using HTML::Entities instead.";
+ $in =~ s/([<>&"])/$saniarray{$1}/g;
+ return $in;
}
sub getmailbody {
=cut
+# Use portable Storable images
+$MLDBM::DumpMeth=q(portable);
+
my %options = (debug => 0,
help => 0,
for my $i (@indexes) {
untie %{$slow_index{$i}};
move("$indexdest/by-$i$suffix.idx.new", "$indexdest/by-$i$suffix.idx");
- system('touch','-d',"1/1/1970 + ${start_time}secs","$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");
}
+
use Debbugs::MIME qw(decode_rfc1522 create_mime_message);
use Debbugs::Mail qw(send_mail_message encode_headers);
use Debbugs::Packages qw(getpkgsrc);
+use Debbugs::User qw(read_usertags write_usertags);
my $config_path = '/etc/debbugs';
my $lib_path = '/usr/lib/debbugs';
print DEBUG ">$fn|$fv|\n";
$fn = lc $fn;
# Don't lc owner or forwarded
- $fv = lc $fv unless $fh =~ /^(?:owner|forwarded)$/;
+ $fv = lc $fv unless $fh =~ /^(?:owner|forwarded|usertags)$/;
$pheader{$fn} = $fv;
print DEBUG ">$fn~$fv<\n";
}
$data->{subject} = $subject;
$data->{msgid} = $header{'message-id'};
writebug($ref, $data);
+ # Deal with usertags
+ if (exists $pheader{usertags}) {
+ my $user = $replyto;
+ $user = $pheader{user} if exists $pheader{user};
+ $user =~ s/,.*//;
+ $user =~ s/^.*<(.*)>.*$/$1/;
+ $user =~ s/[(].*[)]//;
+ $user =~ s/^\s*(\S+)\s+.*$/$1/;
+ if ($user ne '' and Debbugs::User::is_valid_user($user)) {
+ $pheader{usertags} =~ s/(?:^\s+|\s+$)//g;
+ my %user_tags;
+ read_usertags(\%user_tags,$user);
+ for my $tag (split /[,\s]+/, $pheader{usertags}) {
+ if ($tag =~ /^[a-zA-Z0-9.+\@-]+/) {
+ my %bugs_with_tag;
+ @bugs_with_tag{@{$user_tags{$tag}}} = (1) x @{$user_tags{$tag}};
+ $bugs_with_tag{$ref} = 1;
+ $user_tags{$tag} = [keys %bugs_with_tag];
+ }
+ }
+ write_usertags(\%usertags,$user);
+ }
+ else {
+ $brokenness .=<<END;
+Your message tried to set a usertag, but didn't have a valid
+user set ('$user' isn't valid)
+END
+ }
+ }
&overwrite("db-h/$hash/$ref.report",
join("\n",@msg)."\n");
}
$replyto = $header{'from'};
}
+# This is an error counter which should be incremented every time there is an error.
+my $errors = 0;
$controlrequestaddr= $control ? "control\@$gEmailDomain" : "request\@$gEmailDomain";
$transcript='';
&transcript("Processing commands for $controlrequestaddr:\n\n");
"detailed logs for $gBug#$ref");
} elsif (m/^index(\s+full)?$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^index-summary\s+by-package$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^index-summary(\s+by-number)?$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^index(\s+|-)pack(age)?s?$/i) {
&sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
$ok++;
} elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^send-unmatched\s+(last|-1)$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^send-unmatched\s+(old|-2)$/i) {
&transcript("This BTS function is currently disabled, sorry.\n\n");
+ $errors++;
$ok++; # well, it's not really ok, but it fixes #81224 :)
} elsif (m/^getinfo\s+([\w-.]+)$/i) {
# the following is basically a Debian-specific kludge, but who cares
$user = $newuser;
} else {
&transcript("Selected user id ($newuser) invalid, sorry\n");
+ $errors++;
$user = "";
}
} elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
my ($o, $txt) = ($1, $2);
if ($#cats == -1 && $o eq "+") {
&transcript("User defined category specification must start with a category name. Skipping.\n\n");
+ $errors++;
$bad = 1;
next;
}
$desc = ""; $op = $1;
} else {
&transcript("Unrecognised syntax for category section. Skipping.\n\n");
+ $errors++;
$bad = 1;
next;
}
$ref = $1; $addsubcode = $3 || "+"; $tags = $4;
if ($user eq "") {
&transcript("No valid user selected\n");
+ $errors++;
} elsif (&setbug) {
&nochangebug;
my %ut;
}
if (@badtags) {
&transcript("Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n");
+ $errors++;
}
for my $t (keys %chtags) {
$ut{$t} = [] unless defined $ut{$t};
(Use control\@$gEmailDomain to manipulate reports.)
END
+ $errors++;
if (++$unknowns >= 3) {
&transcript("Too many unknown commands, stopping here.\n\n");
last;
if (&setbug) {
if (!length($data->{done}) and not defined($version)) {
&transcript("$gBug is already open, cannot reopen.\n\n");
+ $errors++;
&nochangebug;
} else {
$action=
if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
&transcript("Severity level \`$newseverity' is not known.\n".
"Recognized are: $gShowSeverities.\n\n");
+ $errors++;
} elsif (exists $gObsoleteSeverities{$newseverity}) {
&transcript("Severity level \`$newseverity' is obsolete. " .
- "$gObsoleteSeverities{$newseverity}\n\n");
+ "Use $gObsoleteSeverities{$newseverity} instead.\n\n");
+ $errors++;
} elsif (&setbug) {
$printseverity= $data->{severity};
$printseverity= "$gDefaultSeverity" if $printseverity eq '';
if (@badtags) {
&transcript("Unknown tag/s: ".join(', ', @badtags).".\n".
"Recognized are: ".join(' ', @gTags).".\n\n");
+ $errors++;
}
if (&setbug) {
if ($data->{keywords} eq '') {
}
if (@badblockers) {
&transcript("Unknown blocking bug/s: ".join(', ', @badblockers).".\n");
+ $errors++;
}
$ref=$bugnum;
if (length($mismatch)) {
&transcript("Mismatch - only $gBugs in same state can be merged:\n".
$mismatch."\n");
+ $errors++;
&cancelbug; @newmergelist=(); last;
}
push(@newmergelist,$ref);
if ($data->{package} ne $master_bug_data->{package}) {
&transcript("Mismatch - only $gBugs in the same package can be forcibly merged:\n".
"$gBug $ref is not in the same package as $master_bug\n");
+ $errors++;
&cancelbug; @newmergelist=(); last;
}
for my $t (split /\s+/,$data->{keywords}) {
$bug_affected{$ref} = 1;
if (&setbug) {
if (length($data->{mergedwith})) {
- &transcript("$gBug is marked as being merged with others.\n\n");
+ &transcript("$gBug is marked as being merged with others. Use an existing clone.\n\n");
+ $errors++;
&nochangebug;
} else {
&filelock("nextnumber.lock");
}
} else {
&transcript("Unknown command or malformed arguments to command.\n\n");
+ $errors++;
if (++$unknowns >= 5) {
&transcript("Too many unknown commands, stopping here.\n\n");
last;
&transcript(">\nEnd of message, stopping processing here.\n\n");
}
if (!$ok && !quickabort) {
+ $errors++;
&transcript("No commands successfully parsed; sending the help text(s).\n");
&sendhelp;
&transcript("\n");
$header{'subject'} = "your mail";
}
+# Error text here advertises how many errors there were
+my $error_text = $errors > 0 ? " (with $errors errors)":'';
+
$reply= <<END;
From: $gMaintainerEmail ($gProject $gBug Tracking System)
To: $replyto
-${maintccs}Subject: Processed: $header{'subject'}
+${maintccs}Subject: Processed${error_text}: $header{'subject'}
In-Reply-To: $header{'message-id'}
References: $header{'message-id'}
Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
sub checkpkglimit {
if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
&transcript("$gBug number $ref belongs to package $data->{package}, skipping.\n\n");
+ $errors++;
return 0;
}
return 1;
# &transcript("$action\n\n")
# endmerge
-sub notfoundbug { &transcript("$gBug number $ref not found.\n\n"); }
+sub notfoundbug { &transcript("$gBug number $ref not found. (Is it archived?)\n\n"); }
sub foundbug { &transcript("$gBug#$ref: $data->{subject}\n"); }
sub getmerge {
-# $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