--- /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 qw(splitpackages);
+use Debbugs::Packages qw(getsrcpkgs);
+use Debbugs::Common qw(getparsedaddrs getmaintainers getmaintainers_reverse);
+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 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,
+ },
+ 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,
+ },
+ src => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ maint => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ },
+ );
+ my %bugs = ();
+
+ # We handle src packages, maint and maintenc by mapping to the
+ # appropriate binary packages, then removing all packages which
+ # don't match all queries
+ my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
+ qw(package src maint)
+ );
+ if (exists $param{package} or
+ exists $param{src} or
+ exists $param{maint}) {
+ delete @param{qw(maint src)};
+ $param{package} = [@packages];
+ }
+ my $keys = keys(%param) - 1;
+ die "Need at least 1 key to search by" unless $keys;
+ my $arc = $param{archive} ? '-arc':'';
+ my %idx;
+ for my $key (grep {$_ ne 'archive'} 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{$_}?($_):()} 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,
+ },
+ 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})}
+ }
+ # We handle src packages, maint and maintenc by mapping to the
+ # appropriate binary packages, then removing all packages which
+ # don't match all queries
+ my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
+ qw(package src maint)
+ );
+ if (exists $param{package} or
+ exists $param{src} or
+ exists $param{maint}) {
+ delete @param{qw(maint src)};
+ $param{package} = [@packages];
+ }
+ my @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;
+}
+
+sub __handle_pkg_src_and_maint{
+ my %param = validate_with(params => \@_,
+ spec => {package => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ src => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ maint => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ },
+ allow_extra => 1,
+ );
+
+ my @packages = __make_list($param{package});
+ my $package_keys = @packages?1:0;
+ my %packages;
+ @packages{@packages} = (1) x @packages;
+ if (exists $param{src}) {
+ # We only want to increment the number of keys if there is
+ # something to match
+ my $key_inc = 0;
+ for my $package (map { getsrcpkgs($_)} __make_list($param{src})) {
+ $packages{$package}++;
+ $key_inc=1;
+ }
+ $package_keys += $key_inc;
+ }
+ if (exists $param{maint}) {
+ my $key_inc = 0;
+ my $maint_rev = getmaintainers_reverse();
+ for my $package (map { exists $maint_rev->{$_}?@{$maint_rev->{$_}}:()}
+ __make_list($param{maint})) {
+ $packages{$package}++;
+ $key_inc = 1;
+ }
+ $package_keys += $key_inc;
+ }
+ return grep {$packages{$_} >= $package_keys} keys %packages;
+}
+
+
+# This private subroutine takes a scalar and turns it into a list;
+# transforming arrayrefs into their contents along the way. It also
+# turns undef into the empty list.
+sub __make_list{
+ return map {defined $_?(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(getparsedaddrs);
+use Params::Validate qw(validate_with :types);
+use Debbugs::Config qw(:config);
+use Debbugs::Status qw(splitpackages);
+use Mail::Address;
+use POSIX qw(ceil);
+use Storable qw(dclone);
+
+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),
+ qw(submitterurl mainturl)
+ ],
+ html => [qw(html_escape htmlize_bugs htmlize_packagelinks),
+ qw(maybelink htmlize_addresslinks htmlize_maintlinks),
+ ],
+ util => [qw(cgi_parameters quitcgi),
+ qw(getpseudodesc)
+ ],
+ #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,$width,$height) = @_;
+ my $url = Debbugs::URI->new('version.cgi?');
+ $url->query_form(package => $package,
+ found => $found,
+ fixed => $fixed,
+ (defined $width)?(width => $width):(),
+ (defined $height)?(height => $height):()
+ );
+ 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)
+}
+
+=head2 cgi_parameters
+
+ cgi_parameters
+
+Returns all of the cgi_parameters from a CGI script using CGI::Simple
+
+=cut
+
+sub cgi_parameters {
+ my %options = validate_with(params => \@_,
+ spec => {query => {type => OBJECT,
+ can => 'param',
+ },
+ single => {type => ARRAYREF,
+ default => [],
+ },
+ default => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+ my $q = $options{query};
+ my %single;
+ @single{@{$options{single}}} = (1) x @{$options{single}};
+ my %param;
+ for my $paramname ($q->param) {
+ if ($single{$paramname}) {
+ $param{$paramname} = $q->param($paramname);
+ }
+ else {
+ $param{$paramname} = [$q->param($paramname)];
+ }
+ }
+ for my $default (keys %{$options{default}}) {
+ if (not exists $param{$default}) {
+ # We'll clone the reference here to avoid surprises later.
+ $param{$default} = ref($options{default}{$default})?
+ dclone($options{default}{$default}):$options{default}{$default};
+ }
+ }
+ return %param;
+}
+
+
+sub quitcgi {
+ my $msg = shift;
+ print "Content-Type: text/html\n\n";
+ print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
+ print "An error occurred. Dammit.\n";
+ print "Error was: $msg.\n";
+ print "</BODY></HTML>\n";
+ exit 0;
+}
+
+
+my %common_bugusertags;
+
+
+
+=head HTML
+
+=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
+# htmlize_bugs(bugs=>[@bugs]);
+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;
+}
+
+=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->('');
+ }
+}
+
+sub emailfromrfc822{
+ my $addr = getparsedaddrs($_[0] || "");
+ $addr = defined $addr?$addr->address:'';
+ return $addr;
+}
+
+sub mainturl { pkg_url(maint => emailfromrfc822($_[0])); }
+sub submitterurl { pkg_url(submitter => emailfromrfc822($_[0])); }
+sub htmlize_maintlinks {
+ my ($prefixfunc, $maints) = @_;
+ return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
+}
+
+
+my $_maintainer;
+my $_maintainer_rev;
+
+my $_pseudodesc;
+sub getpseudodesc {
+ return $_pseudodesc if $_pseudodesc;
+ my %pseudodesc;
+
+ my $pseudo = new IO::File $config{pseudo_desc_file},'r'
+ or &quitcgi("Unable to open $config{pseudo_desc_file}: $!");
+ while(<$pseudo>) {
+ next unless m/^(\S+)\s+(\S.*\S)\s*$/;
+ $pseudodesc{lc $1} = $2;
+ }
+ close($pseudo);
+ $_pseudodesc = \%pseudodesc;
+ return $_pseudodesc;
+}
+
+
+=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 buglog getparsedaddrs getmaintainers),
+ qw(getmaintainers_reverse)
+ ],
+ quit => [qw(quit)],
+ lock => [qw(filelock unfilelock)],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(qw(lock quit util));
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
-BEGIN {
- use Exporter ();
- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+#use Debbugs::Config qw(:globals);
+use Debbugs::Config qw(:config);
+use IO::File;
+use Debbugs::MIME qw(decode_rfc1522);
+use Mail::Address;
- # set the version for version checking
- $VERSION = 1.00;
+use Fcntl qw(:flock);
- @ISA = qw(Exporter);
- @EXPORT = qw(&fail &NameToPathHash &sani &quit);
- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
+our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH;
- # your exported package globals go here,
- # as well as any optionally exported functions
- @EXPORT_OK = qw();
+=head1 UTILITIES
+
+The following functions are exported by the C<:util> tag
+
+=head2 getbugcomponent
+
+ my $file = getbugcomponent($bug_number,$extension,$location)
+
+Returns the path to the bug file in location C<$location>, bug number
+C<$bugnumber> and extension C<$extension>
+
+=cut
+
+sub getbugcomponent {
+ my ($bugnum, $ext, $location) = @_;
+
+ if (not defined $location) {
+ $location = getbuglocation($bugnum, $ext);
+ # Default to non-archived bugs only for now; CGI scripts want
+ # archived bugs but most of the backend scripts don't. For now,
+ # anything that is prepared to accept archived bugs should call
+ # getbuglocation() directly first.
+ return undef if defined $location and
+ ($location ne 'db' and $location ne 'db-h');
+ }
+ my $dir = getlocationpath($location);
+ return undef if not defined $dir;
+ if (defined $location and $location eq 'db') {
+ return "$dir/$bugnum.$ext";
+ } else {
+ my $hash = get_hashname($bugnum);
+ return "$dir/$hash/$bugnum.$ext";
+ }
}
-use vars @EXPORT_OK;
-use Debbugs::Config qw(%Globals);
-use FileHandle;
+=head2 getbuglocation
+
+ getbuglocation($bug_number,$extension)
+
+Returns the the location in which a particular bug exists; valid
+locations returned currently are archive, db-h, or db. If the bug does
+not exist, returns undef.
+
+=cut
+
+sub getbuglocation {
+ my ($bugnum, $ext) = @_;
+ my $archdir = get_hashname($bugnum);
+ return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext";
+ return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext";
+ return 'db' if -r getlocationpath('db')."/$bugnum.$ext";
+ return undef;
+}
+
+
+=head2 getlocationpath
+
+ getlocationpath($location)
+
+Returns the path to a specific location
+
+=cut
+
+sub getlocationpath {
+ my ($location) = @_;
+ if (defined $location and $location eq 'archive') {
+ return "$config{spool_dir}/archive";
+ } elsif (defined $location and $location eq 'db') {
+ return "$config{spool_dir}/db";
+ } else {
+ return "$config{spool_dir}/db-h";
+ }
+}
+
+
+=head2 get_hashname
+
+ get_hashname
+
+Returns the hash of the bug which is the location within the archive
+
+=cut
+
+sub get_hashname {
+ return "" if ( $_[ 0 ] < 0 );
+ return sprintf "%02d", $_[ 0 ] % 100;
+}
+
+=head2 buglog
+
+ buglog($bugnum);
+
+Returns the path to the logfile corresponding to the bug.
+
+=cut
+
+sub buglog {
+ my $bugnum = shift;
+ my $location = getbuglocation($bugnum, 'log');
+ return getbugcomponent($bugnum, 'log', $location) if ($location);
+ $location = getbuglocation($bugnum, 'log.gz');
+ return getbugcomponent($bugnum, 'log.gz', $location);
+}
+
+
+=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_FH "failed open log<\n" if $DEBUG;
+ print $DEBUG_FH "failed open log err $!<\n" if $DEBUG;
+ &quit("opening $file (appendfile): $!");
+ }
+ print(AP @_) || &quit("writing $file (appendfile): $!");
+ close(AP) || &quit("closing $file (appendfile): $!");
+}
+
+=head2 getparsedaddrs
+
+ my $address = getparsedaddrs($address);
+ my @address = getpasredaddrs($address);
+
+Returns the output from Mail::Address->parse, or the cached output if
+this address has been parsed before. In SCALAR context returns the
+first address parsed.
+
+=cut
+
+
+my %_parsedaddrs;
+sub getparsedaddrs {
+ my $addr = shift;
+ return () unless defined $addr;
+ return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]
+ if exists $_parsedaddrs{$addr};
+ @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr);
+ return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0];
+}
+
+my $_maintainer;
+my $_maintainer_rev;
+sub getmaintainers {
+ return $_maintainer if $_maintainer;
+ my %maintainer;
+ my %maintainer_rev;
+ for my $file (@config{qw(maintainer_file maintainer_file_override)}) {
+ next unless defined $file;
+ my $maintfile = new IO::File $file,'r' or
+ &quitcgi("Unable to open $file: $!");
+ while(<$maintfile>) {
+ next unless m/^(\S+)\s+(\S.*\S)\s*$/;
+ ($a,$b)=($1,$2);
+ $a =~ y/A-Z/a-z/;
+ $maintainer{$a}= $b;
+ for my $maint (map {lc($_->address)} getparsedaddrs($b)) {
+ push @{$maintainer_rev{$maint}},$a;
+ }
+ }
+ close($maintfile);
+ }
+ $_maintainer = \%maintainer;
+ $_maintainer_rev = \%maintainer_rev;
+ return $_maintainer;
+}
+sub getmaintainers_reverse{
+ return $_maintainer_rev if $_maintainer_rev;
+ getmaintainers();
+ return $_maintainer_rev;
+}
+
+
+=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 $fh2 = IO::File->new($lockfile,'w')
+ or die "Unable to open $lockfile for writing: $!";
+ flock($fh2,LOCK_EX|LOCK_NB)
+ or die "Unable to lock $lockfile $!";
+ return $fh2;
+ };
+ 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_FH "quitting >$_[0]<\n" if $DEBUG;
+ 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
-use strict;
+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);
-BEGIN
-{ use Exporter ();
- use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
-
- # set the version for version checking
- $VERSION = 1.00;
+=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);
- @ISA = qw(Exporter);
- @EXPORT = qw(%Globals %GTags %Strong %Severity );
- %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
+BEGIN {
+ # set the version for version checking
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+ $USING_GLOBALS = 0;
- # your exported package globals go here,
- # as well as any optionally exported functions
- @EXPORT_OK = qw(%Globals %GTags %Severity %Strong &ParseConfigFile &ParseXMLConfigFile);
+ @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($gSendmail $gLibPath),
+ qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities),
+ qw(%gSearchEstraier),
+ qw(@gPostProcessall),
+ ],
+ text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote),
+ ],
+ config => [qw(%config)],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(qw(globals text config));
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
}
-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;
+use File::Basename qw(dirname);
+use IO::File;
+use Safe;
+
+=head1 CONFIGURATION VARIABLES
+
+=head2 General Configuration
+
+=over
+
+=cut
+
+# read in the files;
+%config = ();
+# untaint $ENV{DEBBUGS_CONFIG_FILE} if it's owned by us
+# This enables us to test things that are -T.
+if (exists $ENV{DEBBUGS_CONFIG_FILE} and
+ ${[stat($ENV{DEBBUGS_CONFIG_FILE})]}[4] = $<) {
+ $ENV{DEBBUGS_CONFIG_FILE} =~ /(.+)/;
+ $ENV{DEBBUGS_CONFIG_FILE} = $1;
}
+read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config');
-#############################################################################
-# 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;
+=item email_domain $gEmailDomain
+
+The email domain of the bts
+
+=cut
+
+set_default(\%config,'email_domain','bugs.something');
+
+=item list_domain $gListDomain
+
+The list domain of the bts, defaults to the email domain
+
+=cut
+
+set_default(\%config,'list_domain',$config{email_domain});
+
+=item web_host $gWebHost
+
+The web host of the bts; defaults to the email domain
+
+=cut
+
+set_default(\%config,'web_host',$config{email_domain});
+
+=item web_host_bug_dir $gWebHostDir
+
+The directory of the web host on which bugs are kept, defaults to C<''>
+
+=cut
+
+set_default(\%config,'web_host_bug_dir','');
+
+=item web_domain $gWebDomain
+
+Full path of the web domain where bugs are kept, 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 $gHTMLSuffix
+
+Suffix of html pages, defaults to .html
+
+=cut
+
+set_default(\%config,'html_suffix','.html');
+
+=item cgi_domain $gCGIDomain
+
+Full path of the web domain where cgi scripts are kept. Defaults to
+the concatentation of L</web_host> and cgi.
+
+=cut
+
+set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi');
+
+=item mirrors @gMirrors
+
+List of mirrors [What these mirrors are used for, no one knows.]
+
+=cut
+
+
+set_default(\%config,'mirrors',[]);
+
+=item package_pages $gPackagePages
+
+Domain where the package pages are kept; links should work in a
+package_pages/foopackage manner. Defaults to undef, which means that
+package links will not be made.
+
+=cut
+
+
+set_default(\%config,'package_pages',undef);
+
+=item subscription_domain $gSubscriptionDomain
+
+Domain where subscriptions to package lists happen
+
+=cut
+
+
+set_default(\%config,'subscription_domain',undef);
+
+=back
+
+=cut
+
+
+=head2 Project Identification
+
+=over
+
+=item project $gProject
+
+Name of the project
+
+Default: 'Something'
+
+=cut
+
+set_default(\%config,'project','Something');
+
+=item project_title $gProjectTitle
+
+Name of this install of Debbugs, defaults to "L</project> Debbugs Install"
+
+Default: "$config{project} Debbugs Install"
+
+=cut
+
+set_default(\%config,'project_title',"$config{project} Debbugs Install");
+
+=item maintainer $gMaintainer
+
+Name of the maintainer of this debbugs install
+
+Default: 'Local DebBugs Owner's
+
+=cut
+
+set_default(\%config,'maintainer','Local DebBugs Owner');
+
+=item maintainer_webpage $gMaintainerWebpage
+
+Webpage of the maintainer of this install of debbugs
+
+Default: "$config{web_domain}/~owner"
+
+=cut
+
+set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner");
+
+=item maintainer_email
+
+Email address of the maintainer of this Debbugs install
+
+Default: 'root@'.$config{email_domain}
+
+=cut
+
+set_default(\%config,'maintainer_email','root@'.$config{email_domain});
+
+=item unknown_maintainer_email
+
+Email address where packages with an unknown maintainer will be sent
+
+Default: $config{maintainer_email}
+
+=back
+
+=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
+
+=over
+
+=cut
+
+set_default(\%config,'mailer','exim');
+set_default(\%config,'bug','bug');
+set_default(\%config,'bugs','bugs');
+
+=item remove_age
+
+Age at which bugs are archived/removed
+
+Default: 28
+
+=cut
+
+set_default(\%config,'remove_age',28);
+
+=item save_old_bugs
+
+Whether old bugs are saved or deleted
+
+Default: 1
+
+=cut
+
+set_default(\%config,'save_old_bugs',1);
+
+=item distributions
+
+List of valid distributions
+
+Default: qw(experimental unstable testing stable oldstable);
+
+=cut
+
+set_default(\%config,'distributions',[qw(experimental unstable testing stable oldstable)]);
+
+=item removal_distribution_tags
+
+Tags which specifiy distributions to check
+
+Default: @{$config{distributions}}
+
+=cut
+
+set_default(\%config,'removal_distribution_tags',
+ [@{$config{distributions}}]);
+
+=item removal_default_distribution_tags
+
+For removal/archival purposes, all bugs are assumed to have these tags
+set.
+
+Default: qw(unstable testing);
+
+=cut
+
+set_default(\%config,'removal_default_distribution_tags',
+ [qw(unstable testing)]
+ );
+
+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),
+ @{$config{distributions}}
+ ]);
+
+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,'lib_path','/usr/lib/debbugs');
+
+set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers');
+set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override');
+set_default(\%config,'pseudo_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,'post_processall',[]);
+
+=item sendmail
+
+Sets the sendmail binary to execute; defaults to /usr/lib/sendmail
+
+=cut
+
+set_default(\%config,'sendmail',$config{sendmail},'/usr/lib/sendmail');
+
+=back
+
+
+=head2 Text Fields
+
+The following are the only text fields in general use in the scripts;
+a few additional text fields are defined in text.in, but are only used
+in db2html and a few other specialty scripts.
+
+Earlier versions of debbugs defined these values in /etc/debbugs/text,
+but now they are required to be in the configuration file. [Eventually
+the longer ones will move out into a fully fledged template system.]
+
+=cut
+
+=over
+
+=item bad_email_prefix
+
+This prefixes the text of all lines in a bad e-mail message ack.
+
+=cut
+
+set_default(\%config,'bad_email_prefix','');
+
+
+=item text_instructions
+
+This gives more information about bad e-mails to receive.in
+
+=cut
+
+set_default(\%config,'text_instructions',$config{bad_email_prefix});
+
+=item html_tail
+
+This shows up at the end of (most) html pages
+
+=cut
+
+set_default(\%config,'html_tail',<<END);
+ <ADDRESS>$config{maintainer} <<A HREF=\"mailto:$config{maintainer_email}\">$config{maintainer_email}</A>>.
+ Last modified:
+ <!--timestamp-->
+ SUBSTITUTE_DTIME
+ <!--timestamp-->
+ <P>
+ <A HREF=\"http://$config{web_domain}/\">Debian $config{bug} tracking system</A><BR>
+ Copyright (C) 1999 Darren O. Benham,
+ 1997,2003 nCipher Corporation Ltd,
+ 1994-97 Ian Jackson.
+ </ADDRESS>
+END
+
+
+=item html_expire_note
+
+This message explains what happens to archive/remove-able bugs
+
+=cut
+
+set_default(\%config,'html_expire_note',
+ "(Closed $config{bugs} are archived $config{remove_age} days after the last related message is received.)");
+
+=back
+
+=cut
+
+
+sub read_config{
+ my ($conf_file) = @_;
+ # 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) = defined $first_line?$first_line =~ /VERSION:\s*(\d+)/i:undef;
+ if (defined $version) {
+ if ($version == 1) {
+ # Do something here;
+ die "Version 1 configuration files not implemented yet";
+ }
+ else {
+ die "Version $version configuration files are not supported";
+ }
+ }
+ else {
+ # Ugh. Old configuration file
+ # What we do here is we create a new Safe compartment
+ # so fucked up crap in the config file doesn't sink us.
+ my $cpt = new Safe or die "Unable to create safe compartment";
+ # perldoc Opcode; for details
+ $cpt->permit('require',':filesys_read','entereval','caller','pack','unpack','dofile');
+ $cpt->reval(qq(require '$conf_file';));
+ die "Error in configuration file: $@" if $@;
+ # Now what we do is check out the contents of %EXPORT_TAGS to see exactly which variables
+ # we want to glob in from the configuration file
+ for my $variable (@{$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 "$variable $value",qq(\n);
+ if (defined $var_glob) {{
+ no strict 'refs';
+ if ($glob_type eq '%') {
+ $value = {%{*{$var_glob}}} if defined *{$var_glob}{HASH};
}
- print "\n" if $Globals{ 'debug' } > 1;
- next;
- } else {
- print "$key\n";
- }
-
- }
- }
- print "Unknown line in config!($_)\n";
- next;
- }
- return @config;
+ elsif ($glob_type eq '@') {
+ $value = [@{*{$var_glob}}] if defined *{$var_glob}{ARRAY};
+ }
+ else {
+ $value = ${*{$var_glob}};
+ }
+ # We punt here, because we can't tell if the value was
+ # defined intentionally, or if it was just left alone;
+ # this tries to set sane defaults.
+ set_default(\%config,$hash_name,$value) if defined $value;
+ }}
+ }
+ }
}
-END { } # module clean-up code here (global destructor)
+sub __convert_name{
+ my ($variable) = @_;
+ my $hash_name = $variable;
+ $hash_name =~ s/^([\$\%\@])g//;
+ my $glob_type = $1;
+ my $glob_name = 'g'.$hash_name;
+ $hash_name =~ s/(HTML|CGI)/ucfirst(lc($1))/ge;
+ $hash_name =~ s/^([A-Z]+)/lc($1)/e;
+ $hash_name =~ s/([A-Z]+)/'_'.lc($1)/ge;
+ return $hash_name unless wantarray;
+ return ($hash_name,$glob_name,$glob_type);
+}
+
+# set_default
+
+# sets the configuration hash to the default value if it's not set,
+# otherwise doesn't do anything
+# If $USING_GLOBALS, then sets an appropriate global.
+
+sub set_default{
+ my ($config,$option,$value) = @_;
+ my $varname;
+ if ($USING_GLOBALS) {
+ # fix up the variable name
+ $varname = 'g'.join('',map {ucfirst $_} split /_/, $option);
+ # Fix stupid HTML names
+ $varname =~ s/(Html|Cgi)/uc($1)/ge;
+ }
+ # update the configuration value
+ if (not $USING_GLOBALS and not exists $config->{$option}) {
+ $config->{$option} = $value;
+ }
+ elsif ($USING_GLOBALS) {{
+ no strict 'refs';
+ # Need to check if a value has already been set in a global
+ if (defined *{"Debbugs::Config::${varname}"}) {
+ $config->{$option} = *{"Debbugs::Config::${varname}"};
+ }
+ else {
+ $config->{$option} = $value;
+ }
+ }}
+ if ($USING_GLOBALS) {{
+ no strict 'refs';
+ *{"Debbugs::Config::${varname}"} = $config->{$option};
+ }}
+}
+
+
+### import magick
+
+# All we care about here is whether we've been called with the globals or text option;
+# if so, then we need to export some symbols back up.
+# In any event, we call exporter.
+
+sub import {
+ if (grep /^:(?:text|globals)$/, @_) {
+ $USING_GLOBALS=1;
+ for my $variable (map {@$_} @EXPORT_TAGS{map{(/^:(text|globals)$/?($1):())} @_}) {
+ my $tmp = $variable;
+ no strict 'refs';
+ # Yes, I don't care if these are only used once
+ no warnings 'once';
+ # No, it doesn't bother me that I'm assigning an undefined value to a typeglob
+ no warnings 'misc';
+ my ($hash_name,$glob_name,$glob_type) = __convert_name($variable);
+ $tmp =~ s/^[\%\$\@]//;
+ *{"Debbugs::Config::${tmp}"} = ref($config{$hash_name})?$config{$hash_name}:\$config{$hash_name};
+ }
+ }
+ Debbugs::Config->export_to_level(1,@_);
+}
+
+
+1;
--- /dev/null
+
+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);
+use Debbugs::Status qw(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__
+
+
+
+
+
+
use Time::HiRes qw(usleep);
use Mail::Address ();
use Debbugs::MIME qw(encode_rfc1522);
+use Debbugs::Config qw(:config);
+use Params::Validate qw(:types validate_with);
BEGIN{
($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/;
}
+# We set this here so it can be overridden for testing purposes
+our $SENDMAIL = $config{sendmail};
+
=head2 get_addresses
my @addresses = get_addresses('don@debian.org blars@debian.org
=cut
sub send_mail_message{
- die "send_mail_message requires an even number of arguments" if @_ % 2;
- # It would be better to use Param::Validate instead...
- my %param = @_;
-
- die "send_mail_message requires a message" if not defined $param{message};
-
+ my %param = validate_with(params => \@_,
+ spec => {sendmail_arguments => {type => ARRAYREF,
+ default => [qw(-odq -oem -oi)],
+ },
+ parse_for_recipients => {type => BOOLEAN,
+ default => 0,
+ },
+ encode_headers => {type => BOOLEAN,
+ default => 1,
+ },
+ message => {type => SCALAR,
+ },
+ envelope_from => {type => SCALAR,
+ optional => 1,
+ },
+ recipients => {type => ARRAYREF|UNDEF,
+ optional => 1,
+ },
+ },
+ );
my @sendmail_arguments = qw(-odq -oem -oi);
push @sendmail_arguments, '-f', $param{envelope_from} if exists $param{envelope_from};
my ($message,@sendmail_args) = @_;
my ($wfh,$rfh);
- my $pid = open3($wfh,$rfh,$rfh,'/usr/lib/sendmail',@sendmail_args)
- or die "Unable to fork off /usr/lib/sendmail: $!";
+ my $pid = open3($wfh,$rfh,$rfh,$SENDMAIL,@sendmail_args)
+ or die "Unable to fork off $SENDMAIL: $!";
local $SIG{PIPE} = 'IGNORE';
eval {
- print {$wfh} $message or die "Unable to write to /usr/lib/sendmail: $!";
- close $wfh or die "/usr/lib/sendmail exited with $?";
+ print {$wfh} $message or die "Unable to write to $SENDMAIL: $!";
+ close $wfh or die "$SENDMAIL exited with $?";
};
if ($@) {
local $\;
usleep(50_000);
}
if ($loop >= 600) {
- warn "Sendmail didn't exit within 30 seconds";
+ warn "$SENDMAIL didn't exit within 30 seconds";
}
}
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 makesourceversions)
+ ],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(qw(versions mapping));
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
}
use Fcntl qw(O_RDONLY);
use MLDBM qw(DB_File Storable);
+use Storable qw(dclone);
+$MLDBM::DumpMeth = 'portable';
$MLDBM::RemoveTaint = 1;
=head1 NAME
my $_pkgsrc;
my $_pkgcomponent;
+my $_srcpkg;
sub getpkgsrc {
return $_pkgsrc if $_pkgsrc;
return {} unless defined $Debbugs::Packages::gPackageSource;
my %pkgsrc;
my %pkgcomponent;
+ my %srcpkg;
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);
$bin =~ y/A-Z/a-z/;
$pkgsrc{$bin}= $src;
+ push @{$srcpkg{$src}}, $bin;
$pkgcomponent{$bin}= $cmp;
}
close(MM);
$_pkgsrc = \%pkgsrc;
$_pkgcomponent = \%pkgcomponent;
+ $_srcpkg = \%srcpkg;
return $_pkgsrc;
}
sub getsrcpkgs {
my $src = shift;
- return () if !$src;
- my %pkgsrc = %{getpkgsrc()};
- my @pkgs;
- foreach ( keys %pkgsrc ) {
- push @pkgs, $_ if $pkgsrc{$_} eq $src;
- }
- return @pkgs;
+ getpkgsrc() if not defined $_srcpkg;
+ return () if not defined $src or not exists $_srcpkg->{$src};
+ return @{$_srcpkg->{$src}};
}
=item binarytosource
# TODO: This gets hit a lot, especially from buggyversion() - probably
# need an extra cache for speed here.
+ return () unless defined $gBinarySourceMap;
if (tied %_binarytosource or
tie %_binarytosource, 'MLDBM',
- $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
+ $gBinarySourceMap, O_RDONLY) {
# avoid autovivification
- if (exists $_binarytosource{$binname} and
- exists $_binarytosource{$binname}{$binver}) {
+ my $binary = $_binarytosource{$binname};
+ return () unless defined $binary;
+ my %binary = %{$binary};
+ if (exists $binary{$binver}) {
if (defined $binarch) {
- my $src = $_binarytosource{$binname}{$binver}{$binarch};
+ my $src = $binary{$binver}{$binarch};
return () unless defined $src; # not on this arch
# Copy the data to avoid tiedness problems.
- return [@$src];
+ return dclone($src);
} else {
# Get (srcname, srcver) pairs for all architectures and
# remove any duplicates. This involves some slightly tricky
# multidimensional hashing; sorry. Fortunately there'll
# usually only be one pair returned.
my %uniq;
- for my $ar (keys %{$_binarytosource{$binname}{$binver}}) {
- my $src = $_binarytosource{$binname}{$binver}{$ar};
+ for my $ar (keys %{$binary{$binver}}) {
+ my $src = $binary{$binver}{$ar};
next unless defined $src;
$uniq{$src->[0]}{$src->[1]} = 1;
}
if (tied %_sourcetobinary or
tie %_sourcetobinary, 'MLDBM',
- $Debbugs::Packages::gSourceBinaryMap, O_RDONLY) {
+ $gSourceBinaryMap, O_RDONLY) {
# avoid autovivification
- if (exists $_sourcetobinary{$srcname} and
- exists $_sourcetobinary{$srcname}{$srcver}) {
- my $bin = $_sourcetobinary{$srcname}{$srcver};
+ my $source = $_sourcetobinary{$srcname};
+ return () unless defined $source;
+ my %source = %{$source};
+ if (exists $source{$srcver}) {
+ my $bin = $source{$srcver};
return () unless defined $bin;
- # Copy the data to avoid tiedness problems.
return @$bin;
}
}
return map [$_, $srcver], @srcpkgs;
}
+=item getversions
+
+Returns versions of the package in a 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: $!";
+ }
+ my $version = $_versions{$pkg};
+ return () unless defined $version;
+ my %version = %{$version};
+
+ if (defined $arch and exists $version{$dist}{$arch}) {
+ my $ver = $version{$pkg}{$dist}{$arch};
+ return $ver if defined $ver;
+ return ();
+ } else {
+ my %uniq;
+ for my $ar (keys %{$version{$dist}}) {
+ $uniq{$version{$dist}{$ar}} = 1 unless $ar eq 'source';
+ }
+ if (%uniq) {
+ return keys %uniq;
+ } elsif (exists $version{$dist}{source}) {
+ # Maybe this is actually a source package with no corresponding
+ # binaries?
+ return $version{$dist}{source};
+ } else {
+ return ();
+ }
+ }
+}
+
+
+=item makesourceversions
+
+ @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
+
+Canonicalize versions into source versions, which have an explicitly
+named source package. This is used to cope with source packages whose
+names have changed during their history, and with cases where source
+version numbers differ from binary version numbers.
+
+=cut
+
+my %_sourceversioncache = ();
+sub makesourceversions {
+ my $pkg = shift;
+ my $arch = shift;
+ my %sourceversions;
+
+ for my $version (@_) {
+ if ($version =~ m[/]) {
+ # Already a source version.
+ $sourceversions{$version} = 1;
+ } else {
+ my $cachearch = (defined $arch) ? $arch : '';
+ my $cachekey = "$pkg/$cachearch/$version";
+ if (exists($_sourceversioncache{$cachekey})) {
+ for my $v (@{$_sourceversioncache{$cachekey}}) {
+ $sourceversions{$v} = 1;
+ }
+ next;
+ }
+
+ my @srcinfo = binarytosource($pkg, $version, $arch);
+ unless (@srcinfo) {
+ # We don't have explicit information about the
+ # binary-to-source mapping for this version (yet). Since
+ # this is a CGI script and our output is transient, we can
+ # get away with just looking in the unversioned map; if it's
+ # wrong (as it will be when binary and source package
+ # versions differ), too bad.
+ my $pkgsrc = getpkgsrc();
+ if (exists $pkgsrc->{$pkg}) {
+ @srcinfo = ([$pkgsrc->{$pkg}, $version]);
+ } elsif (getsrcpkgs($pkg)) {
+ # If we're looking at a source package that doesn't have
+ # a binary of the same name, just try the same version.
+ @srcinfo = ([$pkg, $version]);
+ } else {
+ next;
+ }
+ }
+ $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
+ $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
+ }
+ }
+
+ return sort keys %sourceversions;
+}
+
+
+
=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 :quit);
+use Debbugs::Config qw(:config);
+use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
+use Debbugs::Packages qw(makesourceversions getversions binarytosource);
+use Debbugs::Versions;
+use Debbugs::Versions::Dpkg;
+use POSIX qw(ceil);
+
+
+BEGIN{
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
+ qw(isstrongseverity),
+ ],
+ read => [qw(readbug read_bug lockreadbug)],
+ write => [qw(writebug makestatus unlockwritebug)],
+ versions => [qw(addfoundversions addfixedversions),
+ qw(removefoundversions)
+ ],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(qw(status read write versions));
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+
+=head2 readbug
+
+ readbug($bug_num,$location)
+ readbug($bug_num)
+
+Reads a summary file from the archive given a bug number and a bug
+location. Valid locations are those understood by L</getbugcomponent>
+
+=cut
+
+
+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);
+
+sub readbug {
+ return read_bug(bug => $_[0],
+ (@_ > 1)?(location => $_[1]):()
+ );
+}
+
+=head2 read_bug
+
+ read_bug(bug => $bug_num,
+ location => 'archive',
+ );
+ read_bug(summary => 'path/to/bugnum.summary');
+ read_bug($bug_num);
+
+A more complete function than readbug; it enables you to pass a full
+path to the summary file instead of the bug number and/or location.
+
+=head3 Options
+
+=over
+
+=item bug -- the bug number
+
+=item location -- optional location which is passed to getbugcomponent
+
+=item summary -- complete path to the .summary file which will be read
+
+=back
+
+One of C<bug> or C<summary> must be passed. This function will return
+undef on failure, and will die if improper arguments are passed.
+
+=cut
+
+sub read_bug{
+ if (@_ == 1) {
+ unshift @_, 'bug';
+ }
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ optional => 1,
+ regex => qr/^\d+/,
+ },
+ location => {type => SCALAR|UNDEF,
+ optional => 1,
+ },
+ summary => {type => SCALAR,
+ optional => 1,
+ },
+ },
+ );
+ die "One of bug or summary must be passed to read_bug"
+ if not exists $param{bug} and not exists $param{summary};
+ my $status;
+ if (not defined $param{summary}) {
+ my ($lref, $location) = @param{qw(bug location)};
+ if (not defined $location) {
+ $location = getbuglocation($lref,'summary');
+ return undef if not defined $location;
+ }
+ $status = getbugcomponent($lref, 'summary', $location);
+ return undef unless defined $status;
+ }
+ else {
+ $status = $param{summary};
+ }
+ 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)) {
+ # create the found/fixed hashes which indicate when a
+ # particular version was marked found or marked fixed.
+ @{$data{$field}}{@{$data{"${field}_versions"}}} =
+ (('') x (@{$data{"${field}_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 = read_bug(bug => $lref, location => $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} = join ' ', @{$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} and defined $newdata{$field}) {
+ $contents .= "$newdata{$field}\n";
+ } else {
+ $contents .= "\n";
+ }
+ }
+ } elsif ($version == 2 or $version == 3) {
+ # Version 2 or 3. Add a file format version number for the sake of
+ # further extensibility in the future.
+ $contents .= "Format-Version: $version\n";
+ for my $field (keys %fields) {
+ if (exists $newdata{$field} and defined $newdata{$field}
+ and $newdata{$field} ne '') {
+ # Output field names in proper case, e.g. 'Merged-With'.
+ my $properfield = $fields{$field};
+ $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
+ $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}};
+ }
+}
+
+=head2 removefoundversions
+
+ removefoundversions($data,$package,$versiontoremove)
+
+Removes found versions from $data
+
+If a version is fully qualified (contains /) only versions matching
+exactly are removed. Otherwise, all versions matching the version
+number are removed.
+
+Currently $package and $isbinary are entirely ignored, but accepted
+for backwards compatibilty.
+
+=cut
+
+sub removefoundversions {
+ my $data = shift;
+ my $package = shift;
+ my $version = shift;
+ my $isbinary = shift;
+ return unless defined $version;
+
+ foreach my $ver (split /[,\s]+/, $version) {
+ if ($ver =~ m{/}) {
+ # fully qualified version
+ @{$data->{found_versions}} =
+ grep {$_ ne $ver}
+ @{$data->{found_versions}};
+ }
+ else {
+ # non qualified version; delete all matchers
+ @{$data->{found_versions}} =
+ grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
+ @{$data->{found_versions}};
+ }
+ }
+}
+
+
+sub addfixedversions {
+ my $data = shift;
+ my $package = shift;
+ my $version = shift;
+ my $isbinary = shift;
+ return unless defined $version;
+ undef $package if $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(bug => $bug_num);
+
+Options
+
+=over
+
+=item bug -- bug number (required)
+
+=item status -- Status hashref returned by read_bug or get_bug_status (optional)
+
+=item version -- Debbugs::Version information (optional)
+
+=item days_until -- return days until the bug can be archived
+
+=back
+
+Returns 1 if the bug can be archived
+Returns 0 if the bug cannot be archived
+
+If days_until is true, returns the number of days until the bug can be
+archived, -1 if it cannot be archived. 0 means that the bug can be
+archived the next time the archiver runs.
+
+Returns undef on failure.
+
+=cut
+
+# This will eventually need to be fixed before we start using mod_perl
+my $version_cache = {};
+sub bug_archiveable{
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ status => {type => HASHREF,
+ optional => 1,
+ },
+ days_until => {type => BOOLEAN,
+ default => 0,
+ },
+ },
+ );
+ # This is what we return if the bug cannot be archived.
+ my $cannot_archive = $param{days_until}?-1:0;
+ # read the status information
+ my $status = $param{status};
+ if (not exists $param{status} or not defined $status) {
+ $status = read_bug(bug=>$param{bug});
+ return undef if not defined $status;
+ }
+ # Bugs can be archived if they are
+ # 1. Closed
+ return $cannot_archive if not defined $status->{done} or not length $status->{done};
+ # If we just are checking if the bug can be archived, we'll not even bother
+ # checking the versioning information if the bug has been -done for less than 28 days.
+ if (not $param{days_until} and $config{remove_age} >
+ -M getbugcomponent($param{ref},'log')
+ ) {
+ return $cannot_archive;
+ }
+ # At this point, we have to get the versioning information for this bug.
+ # We examine the set of distribution tags. If a bug has no distribution
+ # tags set, we assume a default set, otherwise we use the tags the bug
+ # has set.
+
+ # There must be fixed_versions for us to look at the versioning
+ # information
+ if (@{$status->{fixed_versions}}) {
+ my %dist_tags;
+ @dist_tags{@{$config{removal_distribution_tags}}} =
+ (1) x @{$config{removal_distribution_tags}};
+ my %dists;
+ @dists{@{$config{removal_default_distribution_tags}}} =
+ (1) x @{$config{removal_default_distribution_tags}};
+ for my $tag (split ' ', $status->{tags}) {
+ next unless $dist_tags{$tag};
+ $dists{$tag} = 1;
+ }
+ my %source_versions;
+ for my $dist (keys %dists){
+ my @versions;
+ @versions = getversions($status->{package},
+ $dist,
+ undef);
+ # 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},
+ $dist,
+ @versions);
+ @source_versions{@sourceversions} = (1) x @sourceversions;
+ }
+ if ('found' eq max_buggy(bug => $param{bug},
+ sourceversions => [keys %source_versions],
+ found => $status->{found_versions},
+ fixed => $status->{fixed_versions},
+ version_cache => $version_cache,
+ package => $status->{package},
+ )) {
+ return $cannot_archive;
+ }
+ }
+ # 6. at least 28 days have passed since the last action has occured or the bug was closed
+ # XXX We still need some more work here before we actually can archive;
+ # we really need to track when a bug was closed in a version.
+ my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log'));
+ if ($age > 0 ) {
+ return $param{days_until}?$age:0;
+ }
+ else {
+ return $param{days_until}?0:1;
+ }
+}
+
+
+=head2 get_bug_status
+
+ my $status = get_bug_status(bug => $nnn);
+
+ my $status = get_bug_status($bug_num)
+
+=head3 Options
+
+=over
+
+=item bug -- scalar bug number
+
+=item status -- optional hashref of bug status as returned by readbug
+(can be passed to avoid rereading the bug information)
+
+=item bug_index -- optional tied index of bug status infomration;
+currently not correctly implemented.
+
+=item version -- optional version to check package status at
+
+=item dist -- optional distribution to check package status at
+
+=item arch -- optional architecture to check package status at
+
+=item usertags -- optional hashref of usertags
+
+=item sourceversion -- optional arrayref of source/version; overrides
+dist, arch, and version. [The entries in this array must be in the
+"source/version" format.] Eventually this can be used to for caching.
+
+=back
+
+Note: Currently the version information is cached; this needs to be
+changed before using this function in long lived programs.
+
+=cut
+
+sub get_bug_status {
+ if (@_ == 1) {
+ unshift @_, 'bug';
+ }
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ status => {type => HASHREF,
+ optional => 1,
+ },
+ bug_index => {type => OBJECT,
+ optional => 1,
+ },
+ version => {type => SCALAR,
+ optional => 1,
+ },
+ dist => {type => SCALAR,
+ optional => 1,
+ },
+ arch => {type => SCALAR,
+ optional => 1,
+ },
+ usertags => {type => HASHREF,
+ optional => 1,
+ },
+ sourceversions => {type => ARRAYREF,
+ optional => 1,
+ },
+ },
+ );
+ my %status;
+
+ if (defined $param{bug_index} and
+ exists $param{bug_index}{$param{bug}}) {
+ %status = %{ $param{bug_index}{$param{bug}} };
+ $status{pending} = $status{ status };
+ $status{id} = $param{bug};
+ return \%status;
+ }
+ if (defined $param{status}) {
+ %status = %{$param{status}};
+ }
+ else {
+ my $location = getbuglocation($param{bug}, 'summary');
+ return {} if not length $location;
+ %status = %{ readbug( $param{bug}, $location ) };
+ }
+ $status{id} = $param{bug};
+
+ if (defined $param{usertags}{$param{bug}}) {
+ $status{keywords} = "" unless defined $status{keywords};
+ $status{keywords} .= " " unless $status{keywords} eq "";
+ $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
+ }
+ $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 @sourceversions;
+ if (not exists $param{sourceversions}) {
+ my @versions;
+ if (defined $param{version}) {
+ @versions = ($param{version});
+ } elsif (defined $param{dist}) {
+ @versions = getversions($status{package}, $param{dist}, $param{arch});
+ }
+
+ # TODO: This should probably be handled further out for efficiency and
+ # for more ease of distinguishing between pkg= and src= queries.
+ @sourceversions = makesourceversions($status{package},
+ $param{arch},
+ @versions);
+ }
+ else {
+ @sourceversions = @{$param{sourceversions}};
+ }
+ if (@sourceversions) {
+ my $maxbuggy = max_buggy(bug => $param{bug},
+ sourceversions => \@sourceversions,
+ found => $status{found_versions},
+ fixed => $status{fixed_versions},
+ package => $status{package},
+ version_cache => $version_cache,
+ );
+ 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;
+}
+
+
+=head2 max_buggy
+
+ max_buggy()
+
+=head3 Options
+
+=over
+
+=item bug -- scalar bug number
+
+=item sourceversion -- optional arrayref of source/version; overrides
+dist, arch, and version. [The entries in this array must be in the
+"source/version" format.] Eventually this can be used to for caching.
+
+=back
+
+Note: Currently the version information is cached; this needs to be
+changed before using this function in long lived programs.
+
+
+=cut
+sub max_buggy{
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ sourceversions => {type => ARRAYREF,
+ default => [],
+ },
+ found => {type => ARRAYREF,
+ default => [],
+ },
+ fixed => {type => ARRAYREF,
+ default => [],
+ },
+ package => {type => SCALAR,
+ },
+ version_cache => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+ # Resolve bugginess states (we might be looking at multiple
+ # architectures, say). Found wins, then fixed, then absent.
+ my $maxbuggy = 'absent';
+ for my $version (@{$param{sourceversions}}) {
+ my $buggy = buggy(bug => $param{bug},
+ version => $version,
+ found => $param{found},
+ fixed => $param{fixed},
+ version_cache => $param{version_cache},
+ package => $param{package},
+ );
+ if ($buggy eq 'found') {
+ return 'found';
+ } elsif ($buggy eq 'fixed') {
+ $maxbuggy = 'fixed';
+ }
+ }
+ return $maxbuggy;
+}
+
+
+=head2 buggy
+
+ buggy(bug => nnn,
+ found => \@found,
+ fixed => \@fixed,
+ package => 'foo',
+ version => '1.0',
+ );
+
+Returns the output of Debbugs::Versions::buggy for a particular
+package, version and found/fixed set. Automatically turns found, fixed
+and version into source/version strings.
+
+Caching can be had by using the version_cache, but no attempt to check
+to see if the on disk information is more recent than the cache is
+made. [This will need to be fixed for long-lived processes.]
+
+=cut
+
+sub buggy {
+ my %param = validate_with(params => \@_,
+ spec => {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ found => {type => ARRAYREF,
+ default => [],
+ },
+ fixed => {type => ARRAYREF,
+ default => [],
+ },
+ version_cache => {type => HASHREF,
+ optional => 1,
+ },
+ package => {type => SCALAR,
+ },
+ version => {type => SCALAR,
+ },
+ },
+ );
+ my @found = @{$param{found}};
+ my @fixed = @{$param{fixed}};
+ if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
+ # We have non-source version versions
+ @found = makesourceversions($param{package},undef,
+ @found
+ );
+ @fixed = makesourceversions($param{package},undef,
+ @fixed
+ );
+ }
+ if ($param{version} !~ m{/}) {
+ $param{version} = makesourceversions($param{package},undef,
+ $param{version}
+ );
+ }
+ # Figure out which source packages we need
+ my %sources;
+ @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
+ @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
+ @sources{map {m{(.+)/}; $1} $param{version}} = 1;
+ my $version;
+ if (not defined $param{version_cache} or
+ not exists $param{version_cache}{join(',',sort keys %sources)}) {
+ $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
+ foreach my $source (keys %sources) {
+ my $srchash = substr $source, 0, 1;
+ my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r' or
+ warn "Unable to open $config{version_packages_dir}/$srchash/$source: $!" and next;
+ $version->load($version_fh);
+ }
+ if (defined $param{version_cache}) {
+ $param{version_cache}{join(',',sort keys %sources)} = $version;
+ }
+ }
+ else {
+ $version = $param{version_cache}{join(',',sort keys %sources)};
+ }
+ return $version->buggy($param{version},\@found,\@fixed);
+}
+
+sub isstrongseverity {
+ my $severity = shift;
+ $severity = $config{default_severity} if $severity eq '';
+ return grep { $_ eq $severity } @{$config{strong_severities}};
+}
+
+
+=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 "" and $line[1] == $bug);
+ } elsif ($new eq "REMOVE") {
+ 0;
+ } else {
+ print IDXNEW $new;
+ }
+ if (defined $line and $line ne "" and @line and $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 defined $data->{forwarded} and length $data->{forwarded};
+ $whendone = "done" if defined $data->{done} and 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_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__
+++ /dev/null
-#!/bin/sh
-
-set -e
-
-cwd="`pwd`"
-date="`date +'%d %h %Y'`"
-
-process () {
- (cd config &&
- rm -f trace &&
- m4 -P -I "$config" -DDB_DATE="$date" \
- common/init.m4 config.m4 common/main.m4 - common/final.m4
- )
-}
-
-txtconvert () {
- src=$1; dst=$2
- echo " generating $dst from $src ..."
- rm -f html/txt/$dst.html html/txt/$dst.out
- perl -ne 'print unless m/^Other pages:$/ .. /^\<hr\>/' \
- html/$src.out >html/txt/$dst.html
- HOME=/dev/null lynx -nolist -dump -cfg=/dev/null \
- file://localhost/$cwd/html/txt/$dst.html >html/txt/$dst.out
- rm html/txt/$dst.html
-}
-
-config=local
-if [ $# != 0 ]; then config="$1"; shift; fi
-if [ $# != 0 ]; then echo >&2 'usage: ./build [<config>]'; false; fi
-
-if [ ! -f config/$config/config.m4 ]; then echo >&2 "no such config: $config"; false; fi
-
-errs="`echo 'm4_undivert(1)' | process | sed -ne '/[^ \t]/ s/^/ /p'`"
-if [ "x$errs" != x ]
-then
- echo >&2 'unexpected residues:'
- echo "$errs"
- false
-fi
-
-echo "macro substitutions ..."
-for f in `find -name '*.in'`
-do
- h="`echo $f | sed -e 's/\.in$//'`"
- process <"$f" >"$h.out"
- mv config/trace "$h.trace"
- if egrep 'DBC?U?_' /dev/null "$h.out"
- then
- echo >&2 'undefined macros'
- false
- fi
- [ ! -x "$f" ] || chmod +x "$h.out"
-done
-
-echo "documentation conversion ..."
-txtconvert Reporting.html bug-reporting.txt
-txtconvert Access.html bug-log-access.txt
-txtconvert server-request.html bug-log-mailserver.txt
-txtconvert Developer.html bug-maint-info.txt
-txtconvert server-control.html bug-maint-mailcontrol.txt
-txtconvert server-refcard.html bug-mailserver-refcard.txt
-
-cgilibexist=`echo 'test -f DBC_CGILIB_PATH && echo true || echo false' | process`
-htaccesspath=`echo DBC_HTACCESS_PATH | process`
-
-rm -f install install.new
-process <<'END' >install.new
-#!/bin/sh
- set -e
- test -d DBC_BASE || mkdir DBC_BASE
- bugsid () {
- echo "installing $1 ..."
- test -d "$2" || mkdir "$2"
- cd "$1"
- for f in *.out
- do
- h="`echo $f | sed -e 's/\.out$//'`"
- rm -f "$2/$f"
- cp "./$f" "$2/"
- mv -f "$2/$f" "$2/$h"
- done
- cd "$3"
- }
- bugsid scripts DBC_SCRIPT_PATH ..
- bugsid html DBC_HTML_PATH ..
- bugsid html/txt DBC_DOCDIR_PATH ../..
- bugsid cgi DBC_CGI_PATH ..
-END
-if [ "x$htaccesspath" != x ]; then
- process <<END >>install.new
- cat <<'END2' >$htaccesspath.new
-DBC_HTACCESS_CONTENTS
-END2
- mv -f $htaccesspath.new $htaccesspath
-END
-fi
-
-if $cgilibexist
-then
- cgiii='cgi-lib already exists in DBC_CGILIB_PATH'
-else
- cgiii=' DBC_CGILIB_PATH'
- process <<'END' >>install.new
- echo "installing cgi-lib.pl ..."
- cp cgi/cgi-lib.pl DBC_CGILIB_PATH.new
- mv -f DBC_CGILIB_PATH.new DBC_CGILIB_PATH
-END
-fi
-process >>install.new <<'END'
- echo "setting up bugs database ..."
- DBC_SCRIPT_PATH/initialise
- echo "done."
- echo "You will have to intall the crontab (misc/crontab.out) yourself."
- exit 0
-END
-chmod +x install.new
-mv -f install.new install
-
-cgi="`cd cgi && echo *.out | sed -e 's/\.out//g'`"
-
-process <<END
-built for $config date DB_DATE ...
- will install unchanging files into:
- DBC_SCRIPT_PATH/
- DBC_HTML_PATH/
- DBC_CGI_PATH/ ($cgi)
- $cgiii
- will store data in:
- DB_HTMLDB_PATH/
- DBC_SPOOL_PATH/
- will expect CGI scripts to be available in:
- DBC_CGI_URL/
-END
-
-echo "run ./install to install"
-exit 0
#!/usr/bin/perl -wT
-package debbugs;
-
+use warnings;
use strict;
use POSIX qw(strftime tzset);
use MIME::Parser;
use IO::Scalar;
use IO::File;
-#require '/usr/lib/debbugs/errorlib';
-require './common.pl';
-
-require '/etc/debbugs/config';
-require '/etc/debbugs/text';
-
-use vars(qw($gEmailDomain $gHTMLTail $gSpoolDir $gWebDomain));
+use Debbugs::Config qw(:globals :text);
# 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 :util);
+use Debbugs::Common qw(buglog getmaintainers);
+use Debbugs::Packages qw(getpkgsrc);
+use Debbugs::Status qw(splitpackages get_bug_status isstrongseverity);
use Scalar::Util qw(looks_like_number);
-
-my %param = readparse();
+use CGI::Simple;
+my $q = new CGI::Simple;
+
+my %param = cgi_parameters(query => $q,
+ single => [qw(bug msg att boring terse),
+ qw(reverse mbox mime trim),
+ qw(mboxstat mboxmaint archive),
+ qw(repeatmerged)
+ ],
+ default => {msg => '',
+ boring => 'no',
+ terse => 'no',
+ reverse => 'no',
+ mbox => 'no',
+ mime => 'no',
+ mboxstat => 'no',
+ mboxmaint => 'no',
+ archive => 'no',
+ repeatmerged => 'yes',
+ },
+ );
+# This is craptacular.
my $tail_html;
-my $ref = $param{'bug'} || quitcgi("No bug number");
+my $ref = $param{bug} or quitcgi("No bug number");
$ref =~ /(\d+)/ or quitcgi("Invalid bug number");
$ref = $1;
my $short = "#$ref";
-my $msg = $param{'msg'} || "";
+my $msg = $param{'msg'};
my $att = $param{'att'};
-my $boring = ($param{'boring'} || 'no') eq 'yes';
-my $terse = ($param{'terse'} || 'no') eq 'yes';
-my $reverse = ($param{'reverse'} || 'no') eq 'yes';
-my $mbox = ($param{'mbox'} || 'no') eq 'yes';
-my $mime = ($param{'mime'} || 'yes') eq 'yes';
+my $boring = $param{'boring'} eq 'yes';
+my $terse = $param{'terse'} eq 'yes';
+my $reverse = $param{'reverse'} eq 'yes';
+my $mbox = $param{'mbox'} eq 'yes';
+my $mime = $param{'mime'} eq 'yes';
my $trim_headers = ($param{trim} || ($msg?'no':'yes')) eq 'yes';
+my $mbox_status_message = $param{mboxstat} eq 'yes';
+my $mbox_maint = $param{mboxmaint} 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 $repeatmerged = ($param{'repeatmerged'} || 'yes') eq 'yes';
-set_option('archive', $archive);
-set_option('repeatmerged', $repeatmerged);
+my $archive = $param{'archive'} eq 'yes';
+my $repeatmerged = $param{'repeatmerged'} eq 'yes';
my $buglog = buglog($ref);
foreach (qw(From To Cc Subject Date)) {
my $head_field = $head->get($_);
next unless defined $head_field and $head_field ne '';
- push @headers, qq(<b>$_:</b> ) . htmlsanit(decode_rfc1522($head_field));
+ push @headers, qq(<b>$_:</b> ) . html_escape(decode_rfc1522($head_field));
}
$$this .= join(qq(), @headers) unless $terse;
} else {
- $$this .= htmlsanit(decode_rfc1522($entity->head->stringify));
+ $$this .= html_escape(decode_rfc1522($entity->head->stringify));
}
$$this .= "</pre>\n";
}
unless (($top and $type =~ m[^text(?:/plain)?(?:;|$)]) or
($type =~ m[^multipart/])) {
push @$attachments, $entity;
- my @dlargs = ($ref, "msg=$xmessage", "att=$#$attachments");
- push @dlargs, "filename=$filename" if $filename ne '';
+ my @dlargs = ($ref, msg=>$xmessage, att=>$#$attachments);
+ push @dlargs, (filename=>$filename) if $filename ne '';
my $printname = $filename;
$printname = 'Message part ' . ($#$attachments + 1) if $filename eq '';
- $$this .= '<pre class="mime">[<a href="' . bugurl(@dlargs) . qq{">$printname</a> } .
+ $$this .= '<pre class="mime">[<a href="' . bug_url(@dlargs) . qq{">$printname</a> } .
"($type, $disposition)]</pre>\n";
if ($msg and defined($att) and $att eq $#$attachments) {
my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i;
my $body = $entity->bodyhandle->as_string;
$body = convert_to_utf8($body,$charset) if defined $charset;
- $body = htmlsanit($body);
+ $body = html_escape($body);
# Add links to URLs
$body =~ s,((ftp|http|https)://[\S~-]+?/?)((\>\;)?[)]?[']?[:.\,]?(\s|$)),<a href=\"$1\">$1</a>$3,go;
# Add links to bug closures
$body =~ s[(closes:\s*(?:bug)?\#?\s?\d+(?:,?\s*(?:bug)?\#?\s?\d+)*)
- ][my $temp = $1; $temp =~ s{(\d+)}{qq(<a href=").bugurl($1).qq(">$1</a>)}ge; $temp;]gxie;
+ ][my $temp = $1; $temp =~ s{(\d+)}{qq(<a href=").bug_url($1).qq(">$1</a>)}ge; $temp;]gxie;
$$this .= qq(<pre class="message">$body</pre>\n);
}
}
my $tpack;
my $tmain;
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-my $dtime = strftime "%a, %e %b %Y %T UTC", localtime;
-$tail_html = $debbugs::gHTMLTail;
+my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
+$tail_html = $gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
-my %status = %{getbugstatus($ref)};
+my %status = %{get_bug_status(bug=>$ref)};
unless (%status) {
print <<EOF;
Content-Type: text/html; charset=utf-8
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
-<head><title>$short - $debbugs::gProject $debbugs::gBug report logs</title></head>
+<head><title>$short - $gProject $gBug report logs</title></head>
<body>
-<h1>$debbugs::gProject $debbugs::gBug report logs - $short</h1>
-<p>There is no record of $debbugs::gBug $short.
+<h1>$gProject $gBug report logs - $short</h1>
+<p>There is no record of $gBug $short.
Try the <a href="http://$gWebDomain/">search page</a> instead.</p>
$tail_html</body></html>
EOF
$showseverity = "Severity: $status{severity};\n";
}
+if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
+ $indexentry.= q(<div style="float:right"><a href=").
+ version_url($status{package},
+ $status{found_versions},
+ $status{fixed_versions},
+ ).
+ q("><img src=").
+ version_url($status{package},
+ $status{found_versions},
+ $status{fixed_versions},
+ 2,
+ 2,
+ ).qq{"></a></div>};
+}
+
+
$indexentry .= "<div class=\"msgreceived\">\n";
-$indexentry .= htmlpackagelinks($status{package}, 0) . ";\n";
+$indexentry .= htmlize_packagelinks($status{package}, 0) . ";\n";
foreach my $pkg (@tpacks) {
my $tmaint = defined($maintainer{$pkg}) ? $maintainer{$pkg} : '(unknown)';
my $tsrc = defined($pkgsrc{$pkg}) ? $pkgsrc{$pkg} : '(unknown)';
$indexentry .=
- htmlmaintlinks(sub { $_[0] == 1 ? "Maintainer for $pkg is\n"
+ htmlize_maintlinks(sub { $_[0] == 1 ? "Maintainer for $pkg is\n"
: "Maintainers for $pkg are\n" },
$tmaint);
$indexentry .= ";\nSource for $pkg is\n".
- '<a href="'.srcurl($tsrc)."\">$tsrc</a>" if ($tsrc ne "(unknown)");
+ '<a href="'.pkg_url(src=>$tsrc)."\">$tsrc</a>" if ($tsrc ne "(unknown)");
$indexentry .= ".\n";
}
$indexentry .= "<br>";
-$indexentry .= htmladdresslinks("Reported by: ", \&submitterurl,
+$indexentry .= htmlize_addresslinks("Reported by: ", \&submitterurl,
$status{originator}) . ";\n";
$indexentry .= sprintf "Date: %s.\n",
(strftime "%a, %e %b %Y %T UTC", localtime($status{date}));
-$indexentry .= "<br>Owned by: " . htmlsanit($status{owner}) . ".\n"
+$indexentry .= "<br>Owned by: " . html_escape($status{owner}) . ".\n"
if length $status{owner};
$indexentry .= "</div>\n";
$indexentry .= "<h3>$showseverity";
$indexentry .= sprintf "Tags: %s;\n",
- htmlsanit(join(", ", sort(split(/\s+/, $status{tags}))))
+ html_escape(join(", ", sort(split(/\s+/, $status{tags}))))
if length($status{tags});
$indexentry .= "<br>" if (length($showseverity) or length($status{tags}));
my $descmerged = 'Merged with ';
my $mseparator = '';
for my $m (@merged) {
- $descmerged .= $mseparator."<a href=\"" . bugurl($m) . "\">#$m</a>";
+ $descmerged .= $mseparator."<a href=\"" . bug_url($m) . "\">#$m</a>";
$mseparator= ",\n";
}
push @descstates, $descmerged;
if (@{$status{found_versions}}) {
my $foundtext = 'Found in ';
$foundtext .= (@{$status{found_versions}} == 1) ? 'version ' : 'versions ';
- $foundtext .= join ', ', map htmlsanit($_), @{$status{found_versions}};
+ $foundtext .= join ', ', map html_escape($_), @{$status{found_versions}};
push @descstates, $foundtext;
}
-
if (@{$status{fixed_versions}}) {
my $fixedtext = '<strong>Fixed</strong> in ';
$fixedtext .= (@{$status{fixed_versions}} == 1) ? 'version ' : 'versions ';
- $fixedtext .= join ', ', map htmlsanit($_), @{$status{fixed_versions}};
+ $fixedtext .= join ', ', map html_escape($_), @{$status{fixed_versions}};
if (length($status{done})) {
- $fixedtext .= ' by ' . htmlsanit(decode_rfc1522($status{done}));
+ $fixedtext .= ' by ' . html_escape(decode_rfc1522($status{done}));
}
push @descstates, $fixedtext;
-} elsif (length($status{done})) {
- push @descstates, "<strong>Done:</strong> ".htmlsanit(decode_rfc1522($status{done}));
-} elsif (length($status{forwarded})) {
+}
+
+if (@{$status{found_versions}} or @{$status{fixed_versions}}) {
+ push @descstates, '<a href="'.
+ version_url($status{package},
+ $status{found_versions},
+ $status{fixed_versions},
+ ).qq{">Version Graph</a>};
+}
+
+if (length($status{done})) {
+ push @descstates, "<strong>Done:</strong> ".html_escape(decode_rfc1522($status{done}));
+}
+
+if (length($status{forwarded})) {
push @descstates, "<strong>Forwarded</strong> to ".maybelink($status{forwarded});
}
my @blockedby= split(/ /, $status{blockedby});
if (@blockedby && $status{"pending"} ne 'fixed' && ! length($status{done})) {
for my $b (@blockedby) {
- my %s = %{getbugstatus($b)};
+ my %s = %{get_bug_status($b)};
next if $s{"pending"} eq 'fixed' || length $s{done};
- push @descstates, "Fix blocked by <a href=\"" . bugurl($b) . "\">#$b</a>: ".htmlsanit($s{subject});
+ push @descstates, "Fix blocked by <a href=\"" . bug_url($b) . "\">#$b</a>: ".html_escape($s{subject});
}
}
my @blocks= split(/ /, $status{blocks});
if (@blocks && $status{"pending"} ne 'fixed' && ! length($status{done})) {
for my $b (@blocks) {
- my %s = %{getbugstatus($b)};
+ my %s = %{get_bug_status($b)};
next if $s{"pending"} eq 'fixed' || length $s{done};
- push @descstates, "Blocking fix for <a href=\"" . bugurl($b) . "\">#$b</a>: ".htmlsanit($s{subject});
+ push @descstates, "Blocking fix for <a href=\"" . bug_url($b) . "\">#$b</a>: ".html_escape($s{subject});
}
}
@records = read_log_records($buglogfh);
};
if ($@) {
- quitcgi("Bad bug log for $debbugs::gBug $ref. Unable to read records: $@");
+ quitcgi("Bad bug log for $gBug $ref. Unable to read records: $@");
}
undef $buglogfh;
}
-=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);
# Add links to merged bugs
$output =~ s{(?<=Merged )([\d\s]+)(?=\.)}{join(' ',map {bug_links($_)} (split /\s+/, $1))}eo;
# Add links to blocked bugs
- $output =~ s{(?<=Blocking bugs)(?:(of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
+ $output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)}
{(defined $2?$1.bug_links($2):'').$3.
join(' ',map {bug_links($_)} (split /\,?\s+/, $4))}eo;
# Add links to reassigned packages
$output =~ s{(Bug reassigned from package \`)([^\']+)(' to \`)([^\']+)(')}
- {$1.q(<a href=").pkgurl($2).qq(">$2</a>).$3.q(<a href=").pkgurl($4).qq(">$4</a>).$5}eo;
- $output .= '<a href="' . bug
url($ref, 'msg='.($msg_number+1)) . '">Full text</a> and <a href="' .
- bugurl($ref, 'msg='.($msg_number+1), 'mbox') . '">rfc822 format</a> available.';
+ {$1.q(<a href=").pkg_url(pkg=>$2).qq(">$2</a>).$3.q(<a href=").pkg_url(pkg=>$4).qq(">$4</a>).$5}eo;
+ $output .= '<a href="' . bug
_url($ref, msg => ($msg_number+1)) . '">Full text</a> and <a href="' .
+ bug_url($ref, msg => ($msg_number+1), mbox => 'yes') . '">rfc822 format</a> available.';
$output = qq(<div class="$class"><hr>\n<a name="$msg_number"></a>\n) . $output . "</div>\n";
}
$$seen_msg_ids{$msg_id} = 1;
}
$output .= qq(<hr><a name="$msg_number"></a>\n);
- $output .= 'View this message in <a href="' . bugurl($ref, "msg=$msg_number", "mbox") . '">rfc822 format</a>';
+ $output .= 'View this message in <a href="' . bug_url($ref, "msg=$msg_number", "mbox") . '">rfc822 format</a>';
$output .= handle_email_message($record->{text},
ref => $bug_number,
msg_number => $msg_number,
}
# Incomming Mail Message
my ($received,$hostname) = $record->{text} =~ m/Received: \(at (\S+)\) by (\S+)\;/;
- $output .= qq|<hr><p class="msgreceived"><a name="$msg_number"><a name="msg$msg_number">Message received</a> at |.
- htmlsanit("$received\@$hostname") . q| (<a href="| . bugurl($ref, "msg=$msg_number") . '">full text</a>'.q|, <a href="| . bugurl($ref, "msg=$msg_number") . ';mbox=yes">mbox</a>)'.":</p>\n";
+ $output .= qq|<hr><p class="msgreceived"><a name="$msg_number"></a><a name="msg$msg_number">Message received</a> at |.
+ html_escape("$received\@$hostname") . q| (<a href="| . bug_url($ref, msg=>$msg_number) . '">full text</a>'.q|, <a href="| . bug_url($ref, msg=>$msg_number,mbox=>'yes') .'">mbox</a>)'.":</p>\n";
$output .= handle_email_message($record->{text},
ref => $bug_number,
msg_number => $msg_number,
}
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 => "$gBug#$ref <$ref\@$gEmailDomain>",
+ To => "$gBug#$ref <$ref\@$gEmailDomain>",
+ Subject => "Status: $status{subject}",
+ "Reply-To" => "$gBug#$ref <$ref\@$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 "Content-Type: text/html; charset=utf-8\n\n";
-my $title = htmlsanit($status{subject});
+my $title = html_escape($status{subject});
-my $dummy2 = $debbugs::gWebHostBugDir;
+my $dummy2 = $gWebHostBugDir;
print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n";
print <<END;
<HTML><HEAD>
-<TITLE>$short - $title - $debbugs::gProject $debbugs::gBug report logs</TITLE>
+<TITLE>$short - $title - $gProject $gBug report logs</TITLE>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8">
-<link rel="stylesheet" href="$debbugs::gWebHostBugDir/css/bugs.css" type="text/css">
+<link rel="stylesheet" href="$gWebHostBugDir/css/bugs.css" type="text/css">
<script type="text/javascript">
<!--
-function toggle_infmessages(){
- var styles = document.styleSheets;
- var deleted = 0
- for (var i = 0; i < styles.length; i++) {
- for (var j = 0; j < styles[i].cssRules.length; j++) {
- if (styles[i].cssRules[j].cssText == ".infmessage { display: none; }") {
- styles[i].deleteRule(j);
- deleted = 1;
- }
- }
- }
- if (!deleted) {
- styles[0].insertRule(".infmessage { display: none; }",0);
- }
+function toggle_infmessages()
+{
+ allDivs=document.getElementsByTagName("div");
+ for (var i = 0 ; i < allDivs.length ; i++ )
+ {
+ if (allDivs[i].className == "infmessage")
+ {
+ allDivs[i].style.display=(allDivs[i].style.display == 'none') ? 'block' : 'none';
+ }
+ }
}
-->
</script>
</HEAD>
<BODY>
END
-print "<H1>" . "$
debbugs::gProject $debbugs::gBug report logs - <A HREF=\"mailto:$ref\@$gEmailDomain\">$short</A>" .
+print "<H1>" . "$
gProject $gBug report logs - <A HREF=\"mailto:$ref\@$gEmailDomain\">$short</A>" .
"<BR>" . $title . "</H1>\n";
print "$descriptivehead\n";
-print qq(<p><a href="mailto:$ref\@$debbugs::gEmailDomain">Reply</a> ),
- qq(or <a href="mailto:$ref-subscribe\@$debbugs::gEmailDomain">subscribe</a> ),
+print qq(<p><a href="mailto:$ref\@$gEmailDomain">Reply</a> ),
+ qq(or <a href="mailto:$ref-subscribe\@$gEmailDomain">subscribe</a> ),
qq(to this bug.</p>\n);
print qq(<p><a href="javascript:toggle_infmessages();">Toggle useless messages</a></p>);
-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 "$log";
print "<HR>";
print "<p class=\"msgreceived\">Send a report that <a href=\"/cgi-bin/bugspam.cgi?bug=$ref\">this bug log contains spam</a>.</p>\n<HR>\n";
use URI::Escape;
+use Debbugs::Config qw(:globals :text);
$config_path = '/etc/debbugs';
$lib_path = '/usr/lib/debbugs';
-require "$lib_path/errorlib";
+#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(:status :read :versions);
+use Debbugs::CGI qw(:all);
$MLDBM::RemoveTaint = 1;
my @common_grouping = ( 'severity', 'pending' );
my %common_grouping_order = (
'pending' => [ qw( pending forwarded pending-fixed fixed done absent ) ],
- 'severity' => \@debbugs::gSeverityList,
+ 'severity' => \@gSeverityList,
);
my %common_grouping_display = (
'pending' => 'Status',
"forwarded" => "forwarded to upstream software authors",
"absent" => "not applicable to this version",
},
- 'severity' => \%debbugs::gSeverityDisplay,
+ 'severity' => \%gSeverityDisplay,
);
my $common_version;
$use_bug_idx = $val;
if ( $val ) {
$common_headers{pending}{open} = $common_headers{pending}{pending};
- my $bugidx = tie %bugidx, MLDBM => "$debbugs::gSpoolDir/realtime/bug.idx", O_RDONLY
- or quitcgi( "$0: can't open $debbugs::gSpoolDir/realtime/bug.idx ($!)\n" );
+ my $bugidx = tie %bugidx, MLDBM => "$gSpoolDir/realtime/bug.idx", O_RDONLY
+ or quitcgi( "$0: can't open $gSpoolDir/realtime/bug.idx ($!)\n" );
$bugidx->RemoveTaint(1);
} else {
untie %bugidx;
return %ret;
}
-sub quitcgi {
- my $msg = shift;
- print "Content-Type: text/html\n\n";
- print "<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY>\n";
- print "An error occurred. Dammit.\n";
- print "Error was: $msg.\n";
- print "</BODY></HTML>\n";
- exit 0;
-}
-
-#sub abort {
-# my $msg = shift;
-# my $Archive = $common_archive ? "archive" : "";
-# print header . start_html("Sorry");
-# print "Sorry bug #$msg doesn't seem to be in the $Archive database.\n";
-# print end_html;
-# exit 0;
-#}
-
-# 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;
-}
-
-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) {
if (length($status{done})) {
$result .= ";\n<strong>Done:</strong> " . htmlsanit($status{done});
- $days = ceil($debbugs::gRemoveAge - -M buglog($status{id}));
+ $days = ceil($gRemoveAge - -M buglog($status{id}));
if ($days >= 0) {
$result .= ";\n<strong>Will be archived:</strong>" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" );
} else {
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 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";
}
$result = $header . $result if ( $common{show_list_header} );
- $result .= $debbugs::gHTMLExpireNote if $debbugs::gRemoveAge and $anydone;
+ $result .= $gHTMLExpireNote if $gRemoveAge and $anydone;
$result .= "<hr>" . $footer if ( $common{show_list_footer} );
return $result;
}
sub countbugs {
my $bugfunc = shift;
if ($common_archive) {
- open I, "<$debbugs::gSpoolDir/index.archive"
- or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
+ open I, "<$gSpoolDir/index.archive"
+ or &quitcgi("$gSpoolDir/index.archive: $!");
} else {
- open I, "<$debbugs::gSpoolDir/index.db"
- or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
+ open I, "<$gSpoolDir/index.db"
+ or &quitcgi("$gSpoolDir/index.db: $!");
}
my %count = ();
if (!defined $opt) {
# leave $fastidx undefined;
} elsif (!$common_archive) {
- $fastidx = "$debbugs::gSpoolDir/by-$opt.idx";
+ $fastidx = "$gSpoolDir/by-$opt.idx";
} else {
- $fastidx = "$debbugs::gSpoolDir/by-$opt-arc.idx";
+ $fastidx = "$gSpoolDir/by-$opt-arc.idx";
}
if (defined $fastidx && -e $fastidx) {
print STDERR "done optimized\n" if ($debug);
} else {
if ( $common_archive ) {
- open I, "<$debbugs::gSpoolDir/index.archive"
- or &quitcgi("$debbugs::gSpoolDir/index.archive: $!");
+ open I, "<$gSpoolDir/index.archive"
+ or &quitcgi("$gSpoolDir/index.archive: $!");
} else {
- open I, "<$debbugs::gSpoolDir/index.db"
- or &quitcgi("$debbugs::gSpoolDir/index.db: $!");
+ open I, "<$gSpoolDir/index.db"
+ or &quitcgi("$gSpoolDir/index.db: $!");
}
while(<I>) {
if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
return $encoded;
}
-my $_maintainer;
-sub getmaintainers {
- return $_maintainer if $_maintainer;
- my %maintainer;
-
- open(MM,"$debbugs::gMaintainerFile") or &quitcgi("open $debbugs::gMaintainerFile: $!");
- while(<MM>) {
- next unless m/^(\S+)\s+(\S.*\S)\s*$/;
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $maintainer{$a}= $b;
- }
- close(MM);
- if (defined $debbugs::gMaintainerFileOverride) {
- open(MM,"$debbugs::gMaintainerFileOverride") or &quitcgi("open $debbugs::gMaintainerFileOverride: $!");
- while(<MM>) {
- next unless m/^(\S+)\s+(\S.*\S)\s*$/;
- ($a,$b)=($1,$2);
- $a =~ y/A-Z/a-z/;
- $maintainer{$a}= $b;
- }
- close(MM);
- }
- $_maintainer = \%maintainer;
- return $_maintainer;
-}
-
-my $_pseudodesc;
-sub getpseudodesc {
- return $_pseudodesc if $_pseudodesc;
- my %pseudodesc;
-
- open(PSEUDO, "< $debbugs::gPseudoDescFile") or &quitcgi("open $debbugs::gPseudoDescFile: $!");
- while(<PSEUDO>) {
- next unless m/^(\S+)\s+(\S.*\S)\s*$/;
- $pseudodesc{lc $1} = $2;
- }
- close(PSEUDO);
- $_pseudodesc = \%pseudodesc;
- return $_pseudodesc;
-}
sub getbugstatus {
- my $bugnum = shift;
-
- my %status;
-
- if ( $use_bug_idx eq 1 && exists( $bugidx{ $bugnum } ) ) {
- %status = %{ $bugidx{ $bugnum } };
- $status{ pending } = $status{ status };
- $status{ id } = $bugnum;
- return \%status;
- }
-
- my $location = getbuglocation( $bugnum, 'summary' );
- return {} if ( !$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;
-}
-
-sub buglog {
- my $bugnum = shift;
- my $location = getbuglocation($bugnum, 'log');
- return getbugcomponent($bugnum, 'log', $location) if ($location);
- $location = getbuglocation($bugnum, 'log.gz');
- return getbugcomponent($bugnum, 'log.gz', $location);
-}
-
-# Canonicalize versions into source versions, which have an explicitly
-# named source package. This is used to cope with source packages whose
-# names have changed during their history, and with cases where source
-# version numbers differ from binary version numbers.
-my %_sourceversioncache = ();
-sub makesourceversions {
- my $pkg = shift;
- my $arch = shift;
- my %sourceversions;
-
- for my $version (@_) {
- if ($version =~ m[/]) {
- # Already a source version.
- $sourceversions{$version} = 1;
- } else {
- my $cachearch = (defined $arch) ? $arch : '';
- my $cachekey = "$pkg/$cachearch/$version";
- if (exists($_sourceversioncache{$cachekey})) {
- for my $v (@{$_sourceversioncache{$cachekey}}) {
- $sourceversions{$v} = 1;
- }
- next;
- }
-
- my @srcinfo = binarytosource($pkg, $version, $arch);
- unless (@srcinfo) {
- # We don't have explicit information about the
- # binary-to-source mapping for this version (yet). Since
- # this is a CGI script and our output is transient, we can
- # get away with just looking in the unversioned map; if it's
- # wrong (as it will be when binary and source package
- # versions differ), too bad.
- my $pkgsrc = getpkgsrc();
- if (exists $pkgsrc->{$pkg}) {
- @srcinfo = ([$pkgsrc->{$pkg}, $version]);
- } elsif (getsrcpkgs($pkg)) {
- # If we're looking at a source package that doesn't have
- # a binary of the same name, just try the same version.
- @srcinfo = ([$pkg, $version]);
- } else {
- next;
- }
- }
- $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
- $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
- }
- }
-
- return sort keys %sourceversions;
-}
-
-my %_versionobj;
-sub buggyversion {
- my ($bug, $ver, $status) = @_;
- return '' unless defined $debbugs::gVersionPackagesDir;
- my $src = getpkgsrc()->{$status->{package}};
- $src = $status->{package} unless defined $src;
-
- my $tree;
- if (exists $_versionobj{$src}) {
- $tree = $_versionobj{$src};
- } else {
- $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
- my $srchash = substr $src, 0, 1;
- if (open VERFILE, "< $debbugs::gVersionPackagesDir/$srchash/$src") {
- $tree->load(\*VERFILE);
- close VERFILE;
- }
- $_versionobj{$src} = $tree;
- }
-
- my @found = makesourceversions($status->{package}, undef,
- @{$status->{found_versions}});
- my @fixed = makesourceversions($status->{package}, undef,
- @{$status->{fixed_versions}});
-
- 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 ();
- }
- }
+ my ($bug) = @_;
+ return get_bug_status(bug => $bug,
+ $use_bug_idx?(bug_index => \%bugidx):(),
+ usertags => \%common_bugusertags,
+ (defined $common_dist)?(dist => $common_dist):(),
+ (defined $common_version)?(version => $common_version):(),
+ (defined $common_arch)?(arch => $common_arch):(),
+ );
}
sub getversiondesc {
#!/usr/bin/perl -wT
-package debbugs;
-
+use warnings;
use strict;
-use POSIX qw(strftime tzset nice);
+use POSIX qw(strftime nice);
-#require '/usr/lib/debbugs/errorlib';
+use Debbugs::Config;
+use CGI::Simple;
+use Debbugs::CGI qw(cgi_parameters);
require './common.pl';
-require '/etc/debbugs/config';
-require '/etc/debbugs/text';
-
nice(5);
-my %param = readparse();
+my $q = new CGI::Simple;
+my %param = cgi_parameters(query => $q,
+ single => [qw(indexon repeatmerged archive sortby),
+ qw(skip max_results first),
+ ],
+ default => {indexon => 'pkg',
+ repeatmerged => 'yes',
+ archive => 'no',
+ sortby => 'alpha',
+ skip => 0,
+ max_results => 100,
+ },
+ );
+
+if (defined $param{first}) {
+ # rip out all non-words from first
+ $param{first} =~ s/\W//g;
+}
+if (defined $param{next}) {
+ $param{skip}+=$param{max_results};
+}
+elsif (defined $param{prev}) {
+ $param{skip}-=$param{max_results};
+ $param{skip} = 0 if $param{skip} < 0;
+}
-my $indexon = $param{'indexon'} || 'pkg';
-if ($indexon !~ m/^(pkg|src|maint|submitter|tag)$/) {
+my $indexon = $param{indexon};
+if ($param{indexon} !~ m/^(pkg|src|maint|submitter|tag)$/) {
quitcgi("You have to choose something to index on");
}
-my $repeatmerged = ($param{'repeatmerged'} || "yes") eq "yes";
-my $archive = ($param{'archive'} || "no") eq "yes";
-my $sortby = $param{'sortby'} || 'alpha';
+my $repeatmerged = $param{repeatmerged} eq 'yes';
+my $archive = $param{archive} eq "yes";
+my $sortby = $param{sortby};
if ($sortby !~ m/^(alpha|count)$/) {
quitcgi("Don't know how to sort like that");
}
-#my $include = $param{'include'} || "";
-#my $exclude = $param{'exclude'} || "";
-
my $Archived = $archive ? " Archived" : "";
my %maintainers = %{&getmaintainers()};
my %strings = ();
-$ENV{"TZ"} = 'UTC';
-tzset();
-
-my $dtime = strftime "%a, %e %b %Y %T UTC", localtime;
-my $tail_html = $debbugs::gHTMLTail;
-$tail_html = $debbugs::gHTMLTail;
+my $dtime = strftime "%a, %e %b %Y %T UTC", gmtime;
+my $tail_html = '';#$gHTMLTail;
+$tail_html = '';#$gHTMLTail;
$tail_html =~ s/SUBSTITUTE_DTIME/$dtime/;
-set_option("repeatmerged", $repeatmerged);
-set_option("archive", $archive);
-#set_option("include", { map {($_,1)} (split /[\s,]+/, $include) })
-# if ($include);
-#set_option("exclude", { map {($_,1)} (split /[\s,]+/, $exclude) })
-# if ($exclude);
-
my %count;
my $tag;
my $note;
if ($indexon eq "pkg") {
$tag = "package";
%count = countbugs(sub {my %d=@_; return splitpackages($d{"pkg"})});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "<p>Note that with multi-binary packages there may be other\n";
$note .= "reports filed under the different binary package names.</p>\n";
foreach my $pkg (keys %count) {
} elsif ($indexon eq "src") {
$tag = "source package";
my $pkgsrc = getpkgsrc();
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
%count = countbugs(sub {my %d=@_;
return map {
$pkgsrc->{$_} || $_
map { $_->address } @me;
} splitpackages($d{"pkg"});
});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "<p>Note that maintainers may use different Maintainer fields for\n";
$note .= "different packages, so there may be other reports filed under\n";
$note .= "different addresses.</p>\n";
}
map { $_->address } @se;
});
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
foreach my $sub (keys %count) {
$sortkey{$sub} = lc $fullname{$sub};
$htmldescrip{$sub} = sprintf('<a href="%s">%s</a>',
} elsif ($indexon eq "tag") {
$tag = "tag";
%count = countbugs(sub {my %d=@_; return split ' ', $d{tags}; });
+ if (defined $param{first}) {
+ %count = map {
+ if (/^\Q$param{first}\E/) {
+ ($_,$count{$_});
+ }
+ else {
+ ();
+ }
+ } keys %count;
+ }
$note = "";
foreach my $keyword (keys %count) {
$sortkey{$keyword} = lc $keyword;
} else { # sortby alpha
@orderedentries = sort { $sortkey{$a} cmp $sortkey{$b} } keys %count;
}
+my $skip = $param{skip};
+my $max_results = $param{max_results};
foreach my $x (@orderedentries) {
+ if (not defined $param{first}) {
+ $skip-- and next if $skip > 0;
+ last if --$max_results < 0;
+ }
$result .= "<li>" . $htmldescrip{$x} . " has $count{$x} " .
($count{$x} == 1 ? "bug" : "bugs") . "</li>\n";
}
"</H1>\n";
print $note;
+print <<END;
+<form>
+<input type="hidden" name="skip" value="$param{skip}">
+<input type="hidden" name="max_results" value="$param{max_results}">
+<input type="hidden" name="indexon" value="$param{indexon}">
+<input type="hidden" name="repeatmerged" value="$param{repeatmerged}">
+<input type="hidden" name="archive" value="$param{archive}">
+<input type="hidden" name="sortby" value="$param{sortby}">
+END
+if (defined $param{first}) {
+ print qq(<input type="hidden" name="first" value="$param{first}">\n);
+}
+else {
+ print q(<p>);
+ if ($param{skip} > 0) {
+ print q(<input type="submit" name="prev" value="Prev">);
+ }
+ if (keys %count > ($param{skip} + $param{max_results})) {
+ print q(<input type="submit" name="next" value="Next">);
+ }
+ print qq(</p>\n);
+}
print $result;
print "<hr>\n";
package debbugs;
use strict;
-use POSIX qw(strftime tzset nice);
+use POSIX qw(strftime nice);
-#require '/usr/lib/debbugs/errorlib';
require './common.pl';
-require '/etc/debbugs/config';
-require '/etc/debbugs/text';
-
+use Debbugs::Config qw(:globals :text);
use Debbugs::User;
+use Debbugs::CGI qw(version_url);
+use Debbugs::Common qw(getparsedaddrs);
+use Debbugs::Bugs qw(get_bugs);
use vars qw($gPackagePages $gWebDomain %gSeverityDisplay @gSeverityList);
} ],
"severity" => [ {
"nam" => "Severity",
- "pri" => [map { "severity=$_" } @debbugs::gSeverityList],
- "ttl" => [map { $debbugs::gSeverityDisplay{$_} } @debbugs::gSeverityList],
+ "pri" => [map { "severity=$_" } @gSeverityList],
+ "ttl" => [map { $gSeverityDisplay{$_} } @gSeverityList],
"def" => "Unknown Severity",
- "ord" => [0,1,2,3,4,5,6,7],
+ "ord" => [0..@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/;
$title .= " ($verdesc)" if defined $verdesc;
}
my @pkgs = split /,/, $pkg;
- @bugs = @{getbugs(sub {my %d=@_;
- foreach my $try (splitpackages($d{"pkg"})) {
- return 1 if grep($try eq $_, @pkgs);
- }
- return 0;
- }, 'package', @pkgs)};
+ @bugs = get_bugs(package=>\@pkgs);
} elsif (defined $src) {
add_user("$src\@packages.debian.org");
$title = "source $src";
my $verdesc = getversiondesc($src);
$title .= " ($verdesc)" if defined $verdesc;
}
- my @pkgs = ();
- my @srcs = split /,/, $src;
- foreach my $try (@srcs) {
- push @pkgs, getsrcpkgs($try);
- push @pkgs, $try if ( !grep(/^\Q$try\E$/, @pkgs) );
- }
- @bugs = @{getbugs(sub {my %d=@_;
- foreach my $try (splitpackages($d{"pkg"})) {
- return 1 if grep($try eq $_, @pkgs);
- }
- return 0;
- }, 'package', @pkgs)};
+ @bugs = get_bugs(src=>[split /,/, $src]);
} elsif (defined $maint) {
- my %maintainers = %{getmaintainers()};
add_user($maint);
$title = "maintainer $maint";
$title .= " in $dist" if defined $dist;
- if ($maint eq "") {
- @bugs = @{getbugs(sub {my %d=@_;
- foreach my $try (splitpackages($d{"pkg"})) {
- return 1 if !getparsedaddrs($maintainers{$try});
- }
- return 0;
- })};
- } else {
- my @maints = split /,/, $maint;
- my @pkgs = ();
- foreach my $try (@maints) {
- foreach my $p (keys %maintainers) {
- my @me = getparsedaddrs($maintainers{$p});
- push @pkgs, $p if grep { $_->address eq $try } @me;
- }
- }
- @bugs = @{getbugs(sub {my %d=@_;
- foreach my $try (splitpackages($d{"pkg"})) {
- my @me = getparsedaddrs($maintainers{$try});
- return 1 if grep { $_->address eq $maint } @me;
- }
- return 0;
- }, 'package', @pkgs)};
- }
+ @bugs = get_bugs(maint=>[split /,/,$maint]);
} elsif (defined $maintenc) {
my %maintainers = %{getmaintainers()};
$title = "encoded maintainer $maintenc";
$title = "submitter $submitter";
$title .= " in $dist" if defined $dist;
my @submitters = split /,/, $submitter;
- @bugs = @{getbugs(sub {my %d=@_;
- my @se = getparsedaddrs($d{"submitter"} || "");
- foreach my $try (@submitters) {
- return 1 if grep { $_->address eq $try } @se;
- }
- }, 'submitter-email', @submitters)};
+ @bugs = get_bugs(submitter => \@submitters);
} elsif (defined($severity) && defined($status)) {
$title = "$status $severity bugs";
$title .= " in $dist" if defined $dist;
print "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n";
print "<HTML><HEAD>\n" .
- "<TITLE>$debbugs::gProject$Archived $debbugs::gBug report logs: $title</TITLE>\n" .
- '<link rel="stylesheet" href="/css/bugs.css" type="text/css">' .
+ "<TITLE>$gProject$Archived $gBug report logs: $title</TITLE>\n" .
+ qq(<link rel="stylesheet" href="$gWebHostBugDir/css/bugs.css" type="text/css">) .
"</HEAD>\n" .
'<BODY onload="pagemain();">' .
"\n";
-print "<H1>" . "$debbugs::gProject$Archived $debbugs::gBug report logs: $title" .
+print "<H1>" . "$gProject$Archived $gBug report logs: $title" .
"</H1>\n";
my $showresult = 1;
if ($pkg and defined($pseudodesc) and exists($pseudodesc->{$pkg})) {
push @references, "to the <a href=\"http://${debbugs::gWebDomain}/pseudo-packages${debbugs::gHTMLSuffix}\">list of other pseudo-packages</a>";
} else {
- if ($pkg and defined $debbugs::gPackagePages) {
+ if ($pkg and defined $gPackagePages) {
push @references, sprintf "to the <a href=\"%s\">%s package page</a>", urlsanit("http://${debbugs::gPackagePages}/$pkg"), htmlsanit("$pkg");
}
- if (defined $debbugs::gSubscriptionDomain) {
+ if (defined $gSubscriptionDomain) {
my $ptslink = $pkg ? $srcforpkg : $src;
- push @references, "to the <a href=\"http://$debbugs::gSubscriptionDomain/$ptslink\">Package Tracking System</a>";
+ push @references, "to the <a href=\"http://$gSubscriptionDomain/$ptslink\">Package Tracking System</a>";
}
# Only output this if the source listing is non-trivial.
if ($pkg and $srcforpkg and (@pkgs or $pkg ne $srcforpkg)) {
set_option("archive", !$archive);
printf "<p>See the <a href=\"%s\">%s reports</a></p>",
- urlsanit('pkgreport.cgi?'.join(';',
- (map {$_ eq 'archived'?():("$_=$param{$_}")
- } keys %param
- ),
- ('archived='.($archive?"no":"yes"))
- )
+ urlsanit(pkg_url((
+ map {
+ $_ eq 'archive'?():($_,$param{$_})
+ } keys %param
+ ),
+ ('archive',($archive?"no":"yes"))
+ )
), ($archive ? "active" : "archived");
set_option("archive", $archive);
}
print "<tr><td> </td></tr>\n";
-my $includetags = htmlsanit(join(" ", grep { !m/^subj:/i } split /[\s,]+/, $include));
-my $excludetags = htmlsanit(join(" ", grep { !m/^subj:/i } split /[\s,]+/, $exclude));
-my $includesubj = htmlsanit(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } split /[\s,]+/, $include));
-my $excludesubj = htmlsanit(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } split /[\s,]+/, $exclude));
+my $includetags = htmlsanit(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
+my $excludetags = htmlsanit(join(" ", grep { !m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
+my $includesubj = htmlsanit(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($include)?@{$include}:$include));
+my $excludesubj = htmlsanit(join(" ", map { s/^subj://i; $_ } grep { m/^subj:/i } map {split /[\s,]+/} ref($exclude)?@{$exclude}:$exclude));
my $vismindays = ($mindays == 0 ? "" : $mindays);
my $vismaxdays = ($maxdays == -1 ? "" : $maxdays);
my @fixed = @{$status{fixed_versions}};
$showversions .= join ', ', map {s{/}{ }; 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;
$result .= buglinklist(";\nBlocks ", ", ",
split(/ /,$status{blocks}));
- my $days = 0;
if (length($status{done})) {
$result .= "<br><strong>Done:</strong> " . htmlsanit($status{done});
-# 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>";
-# }
+ my $days = bug_archiveable(bug => $status{id},
+ status => \%status,
+ days_until => 1,
+ );
+ if ($days >= 0) {
+ $result .= ";\n<strong>Will be archived" . ( $days == 0 ? " today" : $days == 1 ? " in $days day" : " in $days days" ) . "</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
my $header = '';
my $footer = "<h2 class=\"outstanding\">Summary</h2>\n";
- my @dummy = ($debbugs::gRemoveAge); #, @debbugs::gSeverityList, @debbugs::gSeverityDisplay); #, $debbugs::gHTMLExpireNote);
+ my @dummy = ($gRemoveAge); #, @gSeverityList, @gSeverityDisplay); #, $gHTMLExpireNote);
if (@bugs == 0) {
return "<HR><H2>No reports found!</H2></HR>\n";
}
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 {
}
sub myurl {
- return urlsanit('pkgreport.cgi?'.
- join(';',
- (map {("$_=$param{$_}")
- } keys %param
- )
- )
+ return urlsanit(pkg_url(map {exists $param{$_}?($_,$param{$_}):()}
+ qw(archive repeatmerged mindays maxdays),
+ qw(version dist arch pkg src tag maint submitter)
+ )
);
}
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 cgi_parameters);
+use HTML::Entities qw(encode_entities);
+
+my $q = new CGI::Simple;
+
+#my %var_defaults = (attr => 1,);
+
+my %cgi_var = cgi_parameters(query => $q,
+ single => [qw(phrase max_results order_field order_operator),
+ qw(skip prev next),
+ ],
+ default => {phrase => '',
+ max_results => 10,
+ skip => 0,
+ },
+ );
+
+$cgi_var{attribute} = parse_attribute(\%cgi_var) || [];
+
+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
+
+
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<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</option>\n);
+}
+print qq(</select></p>\n);
+
+print qq(</tr></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;
+}
--- /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 cgi_parameters);
+use Debbugs::Versions;
+use Debbugs::Versions::Dpkg;
+use Debbugs::Packages qw(getversions makesourceversions);
+use HTML::Entities qw(encode_entities);
+use File::Temp qw(tempdir);
+use IO::File;
+use IO::Handle;
+
+
+my %img_types = (svg => 'image/svg+xml',
+ png => 'image/png',
+ );
+
+my $q = new CGI::Simple;
+
+my %cgi_var = cgi_parameters(query => $q,
+ single => [qw(package format ignore_boring width height)],
+ default => {package => 'xterm',
+ found => [],
+ fixed => [],
+ ignore_boring => 1,
+ format => 'png',
+ width => undef,
+ height => undef,
+ },
+ );
+
+# 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 (@{$config{distributions}}) {
+ $versions{$dist} = [getversions($cgi_var{package},$dist)];
+ # make version_to_dist
+ foreach my $version (@{$versions{$dist}}){
+ push @{$version_to_dist{$version}}, $dist;
+ }
+}
+
+if (defined $cgi_var{width}) {
+ $cgi_var{width} =~ /(\d+)/;
+ $cgi_var{width} = $1;
+}
+if (defined $cgi_var{height}) {
+ $cgi_var{height} =~ /(\d+)/;
+ $cgi_var{height} = $1;
+}
+
+if (defined $cgi_var{format}) {
+ $cgi_var{format} =~ /(png|svg|jpg|gif)/;
+ $cgi_var{format} = $1 || 'png';
+}
+else {
+ $cgi_var{format} = 'png';
+}
+
+# then figure out which are affected.
+# turn found and fixed into full versions
+@{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}});
+@{$cgi_var{fixed}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{fixed}});
+my @interesting_versions = makesourceversions($cgi_var{package},undef,keys %version_to_dist);
+
+# We need to be able to rip out leaves which the versions that do not affect the current versions of unstable/testing
+my %sources;
+@sources{map {m{(.+)/}; $1} @{$cgi_var{found}}} = (1) x @{$cgi_var{found}};
+@sources{map {m{(.+)/}; $1} @{$cgi_var{fixed}}} = (1) x @{$cgi_var{fixed}};
+@sources{map {m{(.+)/}; $1} @interesting_versions} = (1) x @interesting_versions;
+my $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
+foreach my $source (keys %sources) {
+ my $srchash = substr $source, 0, 1;
+ my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", '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";
+if (defined $cgi_var{width} and defined $cgi_var{height}) {
+ $dot .= qq(size="$cgi_var{width},$cgi_var{height}";\n);
+}
+my %state = (found => ['fillcolor="salmon"',
+ 'style="filled"',
+ 'shape="diamond"',
+ ],
+ absent => ['fillcolor="grey"',
+ 'style="filled"',
+ ],
+ fixed => ['fillcolor="chartreuse"',
+ 'style="filled"',
+ 'shape="rect"',
+ ],
+ );
+# TODO: Allow collapsing versions which are at the same state and not
+# in a suite.
+foreach my $key (keys %all_states) {
+ my ($short_version) = $key =~ m{/(.+)$};
+ next if $cgi_var{ignore_boring} and (not defined $all_states{$key}
+ or $all_states{$key} eq 'absent');
+ next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
+ 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}}) {
+ next if not defined $version->{parent}{$key};
+ next if $cgi_var{ignore_boring} and $all_states{$key} eq 'absent';
+ next if $cgi_var{ignore_boring} and (not defined $all_states{$version->{parent}{$key}}
+ or $all_states{$version->{parent}{$key}} eq 'absent');
+ # Ignore branches which are not ancestors of a currently distributed version
+ next if $cgi_var{ignore_boring} and not version_relevant($version,$key,\@interesting_versions);
+ $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','-T'.$cgi_var{format},"$temp_dir/temp.dot",'-o',"$temp_dir/temp.$cgi_var{format}") == 0
+ or print "Content-Type: text\n\nDot failed." and die "Dot failed: $?";
+ my $img_fh = new IO::File "$temp_dir/temp.$cgi_var{format}", 'r' or
+ die "Unable to open $temp_dir/temp.$cgi_var{format} for reading: $!";
+ print "Content-Type: $img_types{$cgi_var{format}}\n\n";
+ print <$img_fh>;
+ close $img_fh;
+}
+else {
+ print "Content-Type: text\n\n";
+ print $dot;
+}
+
+
+my %_version_relevant_cache;
+sub version_relevant {
+ my ($version,$test_version,$relevant_versions) = @_;
+ for my $dist_version (@{$relevant_versions}) {
+ print STDERR "Testing $dist_version against $test_version\n";
+ return 1 if $version->isancestor($test_version,$dist_version);
+ }
+ return 0;
+}
+
+
+++ /dev/null
-#!/bin/sh
-find \( -name '*.out' -o -name '*~' -o -name '#*#' \) -print | xargs -r rm -f --
-rm -f install install.new
+++ /dev/null
-#!/usr/bin/perl -w
-
-push(@INC,'.');
-use strict;
-use Debbugs::Config qw(%Globals &ParseConfigFile);
-#use Debvote::Email qw(&InitEmailTags &LoadEmail &ProcessTags %gtags);
-use Debbugs::DBase;
-use Getopt::Long;
-
-#############################################################################
-# Customization Variables
-#############################################################################
-
-#############################################################################
-# Gloabal Variable Declaration
-#############################################################################
-my $VERSION = '3.01'; #External Version number
-my $BANNER = "DebBugs v$VERSION"; #Version Banner - text form
-my $FILE = 'debbugs-dump'; #File name
-my $config = '';
-my @config = undef;
-
-#############################################################################
-# Commandline parsing
-#############################################################################
-# Hash used to process commandline options
-my $verbose = 0;
-my $quiet = 0;
-my $debug = 0;
-my %opthash = (# ------------------ actions
- "config|c=s" => \$config,
- "help|h" => \&syntax,
- "version|V" => \&banner,
- "verbose|v!" => \$verbose,
- "quiet|q!" => \$quiet,
- "debug|d+" => \$debug, # Count the -d flags
- );
-Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
-GetOptions(%opthash) or &syntax( 1 );
-if ( $debug > 1 )
-{ print "D2: Commandline:\n";
- print "\tconfig = $config\n" unless $config eq '';
- print "\tverbos\n" if $verbose;
- print "\tquiet\n" if $quiet;
- print "\tdebug = $debug\n";
-}
-$Globals{ 'debug' } = $debug;
-$Globals{ 'quiet' } = $quiet;
-$Globals{ 'verbose' } = $verbose;
-
-#############################################################################
-# Read Config File and parse
-#############################################################################
-$config = "./debbugs.cfg" if( $config eq '' );
-print "D1: config file=$config\n" if $Globals{ 'debug' };
-@config = ParseConfigFile( $config );
-
-## Put Real Code Here
-
-my @bugs = Debbugs::DBase::GetBugList(["db", "archive"]);
-print "Active Bugs:";
-foreach (@bugs) {
- print " $_";
-}
-print "\n";
-foreach (@bugs) {
- Debbugs::DBase::OpenRecord( $_ );
- Debbugs::DBase::OpenLogfile( $_ );
- Debbugs::DBase::ReadLogfile( $_ );
- Debbugs::DBase::CloseLogfile();
- Debbugs::DBase::ReadRecord( $_ );
- foreach my $key ( keys( %Record ) )
- {
- print "Key= $key Value = " . $Record{ $key } . "\n";
- }
- Debbugs::DBase::CloseRecord();
-}
-
-#############################################################################
-# Ack Back
-#############################################################################
-
-sub syntax {
- print "$BANNER\n";
- print <<"EOT-EOT-EOT";
-Syntax: $FILE [options]
- -c, --config CFGFILE read CFGFILE for configuration (default=./debvote.cfg)
- -h, --help display this help text
- -v, --verbose verbose messages
- -q, --quiet cancels verbose in a config file
- -V, --version display Debvote version and exit
- -d, --debug turn debug messages ON (multiple -d for more verbose)
-EOT-EOT-EOT
-
- exit $_[0];
-}
+++ /dev/null
-#!/usr/bin/perl -w
-# Usage: service <code>.nn
-# Temps: incoming/P<code>.nn
-
-
-use strict;
-use Debbugs::Config;
-use Debbugs::Email;
-use Debbugs::DBase;
-use Debbugs::Common;
-use Getopt::Long;
-use MIME::Parser;
-
-#############################################################################
-# Gloabal Variable Declaration
-#############################################################################
-my $VERSION = '3.01'; #External Version number
-my $BANNER = "DebBugs v$VERSION"; #Version Banner - text form
-my $FILE = 'debbugs-service'; #File name
-my $config = '';
-my @config = undef;
-
-my $inputfilename; #file specified on commandline
-my @inputfile;
-my @imputlog;
-my $control; #call to control or request
-
-my @body; #list of commands
-my $replyto; #address of to send reply to
-my $transcript = ''; #building of return message
-my %LTags; #Tags Local to this email
-my @message; #holds copy of msg to apply tags
-
-#############################################################################
-# Commandline parsing
-#############################################################################
-# Hash used to process commandline options
-my $verbose = 0;
-my $quiet = 0;
-my $debug = 0;
-my %opthash = (# ------------------ actions
- "config|c=s" => \$config,
- "help|h" => \&syntax,
- "version|V" => \&banner,
- "verbose|v!" => \$verbose,
- "quiet|q!" => \$quiet,
- "debug|d+" => \$debug, # Count the -d flags
- );
-Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');
-GetOptions(%opthash) or &syntax( 1 );
-if ( $debug > 1 )
-{ print "D2: Commandline:\n";
- print "\tconfig = $config\n" unless $config eq '';
- print "\tverbos\n" if $verbose;
- print "\tquiet\n" if $quiet;
- print "\tdebug = $debug\n";
-}
-$Globals{ 'debug' } = $debug;
-$Globals{ 'quiet' } = $quiet;
-$Globals{ 'verbose' } = $verbose;
-
-#############################################################################
-# Read Config File and parse
-#############################################################################
-$config = "./debbugs.cfg" if( $config eq '' );
-print "D1: config file=$config\n" if $Globals{ 'debug' };
-@config = Debbugs::Config::ParseConfigFile( $config );
-
-#############################################################################
-# Load in template emails
-#############################################################################
-@notify_done_email = Debbugs::Email::LoadEmail( $Globals{ 'template-dir' }.'/'.$Globals{ 'not-don-con' } );
-
-#############################################################################
-# Find file name and load input file
-#############################################################################
-$_=shift;
-m/^[RC]\.\d+$/ || &fail("bad argument");
-$control= m/C/;
-$inputfilename = $_;
-if (!rename( $Globals{ 'spool-dir' }."G$inputfilename", $Globals{ 'spool-dir' }."P$inputfilename"))
-{ $_=$!.'';
- m/no such file or directory/i && exit 0;
- &fail("renaming to lock: $!");
-}
-
-############################################################################
-# Set up MIME Message class
-############################################################################
-my $parser = new MIME::Parser;
-$parser->output_dir("$ENV{HOME}/mimemail");
-$parser->output_prefix("part");
-$parser->output_to_core(100000);
-my $inputmail = $parser->parse_in("P$inputfilename") or die "couldn't parse MIME file";
-#for use when stdin in stead of file is used
-#my $inputmail = $parser->read(\*STDIN) or die "couldn't parse MIME stream";
-
-############################################################################
-# Extract first part (if mime type) for processing. All else assumed junk
-############################################################################
-if ( $inputmail->is_multipart )
-{ my $parts = $inputmail->parts( 0 );
- while( $parts->is_multipart ) { $parts = $parts->parts( 0 ); }
- @body = $parts->bodyhandle->as_lines;
-}
-else { @body = $inputmail->bodyhandle->as_lines; }
-
-
-$inputmail->head->count('From') || &fail( "no From header" );
-
-############################################################################
-# Determine Reply To address
-############################################################################
-my $header = $input->mail->head;
-$replyto= $header->count( "Reply-to" ) ? $header->get( "Reply-to" ) : $header->get( "From" );
-
-############################################################################
-# Add Email info to Local Tags (LTags)
-############################################################################
-$LTags{ 'REPLY_TO' ) = $replyto;
-$LTags{ 'CC_TO' ) = $header->get( 'CC' ) if $header->count( 'CC' );
-$LTags{ 'MESSAGE_ID' } = $header->get( 'Message-id' ) if $header->count( 'Message-id' );
-$LTags{ 'MESSAGE_BODY' } = join( '\n', @body );
-$LTags( 'MESSAGE_DATA' } = "control";
-$LTags{ 'MESSAGE_DATE' } = $header->get( 'Date' ) if $header->count( 'Date');
-if ( $header->count( 'Subject' ) )
-{ $LTags{ 'MESSAGE_SUBJECT' } = $header->get( 'Subject' ); }
-else { &transcript( <<END ); }
-Your email does not include a Subject line in the header. This is a
-violation of the specifications and may cause your email to be rejected at
-some later date.
-
-END
-
-############################################################################
-# Start processing of commands
-############################################################################
-if ( $control ) { &transcript("Processing commands for control message:\n\n"); }
-else { &transcript("Processing commands for request message:\n\n"); }
-
-####################################### HERE ###############################
-$state= 'idle';
-$lowstate= 'idle';
-$mergelowstate= 'idle';
-$midix=0;
-$extras="";
-
-for ( my $procline=0; $procline<=$#body; $procline++)
-{
- #test state
- $state eq 'idle' || print "$state ?\n";
- $lowstate eq 'idle' || print "$lowstate ?\n";
- $mergelowstate eq 'idle' || print "$mergelowstate ?\n";
-
- #get line
- $_= $msg[$procline];
- s/\s+$//; #strip ending white space, including newlines
-
- #cleanup line
- next unless m/\S/; #skip blank lines
- next if m/^\s*\#/; #skip comment-only lines
- &transcript("> $_\n");
-
-
- $action= '';
- if (m/^stop\s/i || m/^quit\s/i || m/^--/ || m/^thank\s/i)
- { &transcript("Stopping processing here.\n\n");
- last;
- } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000)
- { $debug= $1+0;
- &transcript("Debug level $debug.\n\n");
- } elsif (m/^(send|get)\s+\#?(\d{2,})$/i)
- { $ref= $2+0; $reffile= $ref; $reffile =~ s,^..,$&/$&,;
- &sendlynxdoc( "db/$reffile.html", "logs for $gBug#$ref" );
- } elsif (m/^send-detail\s+\#?(\d+)$/i)
- { $ref= $1+0; $reffile= $ref; $reffile =~ s,^..,$&/$&,;
- &sendlynxdoc("db/$reffile-b.html","additional logs for $gBug#$ref");
- } elsif (m/^index(\s+full)?$/i) {
- &sendlynxdoc("db/ix/full.html",'full index');
- } elsif (m/^index-summary\s+by-package$/i) {
- &sendlynxdoc("db/ix/psummary.html",'summary index sorted by package/title');
- } elsif (m/^index-summary(\s+by-number)?$/i) {
- &sendlynxdoc("db/ix/summary.html",'summary index sorted by number/date');
- } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
- &sendlynxdoc("db/ix/packages.html",'index of packages');
- } elsif (m/^index(\s+|-)maints?$/i) {
- &sendlynxdoc("db/ix/maintainers.html",'index of maintainers');
- } elsif (m/^index(\s+|-)maint\s+(\S.*\S)$/i) {
- $substrg= $2; $matches=0;
- opendir(DBD,"$gWebDir/db/ma") || die $!;
- while (defined($_=readdir(DBD))) {
- next unless m/^l/ && m/\.html$/;
- &transcript("F|$_\n") if $dl>1;
- $filename= $_; s/^l//; s/\.html$//;
- &transcript("P|$_\n") if $dl>2;
- while (s/-(..)([^_])/-$1_-$2/) { }
- &transcript("P|$_\n") if $dl>2;
- s/^(.{0,2})_/$1-20_/g; while (s/([^-]..)_/$1-20_/) { };
- &transcript("P|$_\n") if $dl>2;
- s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
- &transcript("P|$_\n") if $dl>2;
- s/^([^,]+),(.*),(.*),$/$1-20_-3c_$2-40_$3-3e_/;
- &transcript("P|$_\n") if $dl>2;
- s/\./-2e_/g;
- &transcript("P|$_\n") if $dl>2;
- $out='';
- while (m/-(..)_/) { $out.= $`.sprintf("%c",hex($1)); $_=$'; }
- $out.=$_;
- &transcript("M|$out\n") if $dl>1;
- next unless index(lc $out, lc $substrg)>=0;
- &transcript("S|$filename\n") if $dl>0;
- &transcript("S|$out\n") if $dl>0;
- $matches++;
- &sendlynxdocraw("db/ma/$filename","$gBug list for maintainer \`$out'");
- }
- if ($matches) {
- &transcript("$gBug list(s) for $matches maintainer(s) sent.\n\n");
- } else {
- &transcript("No maintainers found containing \`$substrg'.\n".
- "Use \`index-maint' to get list of maintainers.\n\n");
- }
- $ok++;
- } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
- $substrg= $+; $matches=0;
- opendir(DBD,"$gWebDir/db/pa") || die $!;
- while (defined($_=readdir(DBD))) {
- next unless m/^l/ && m/\.html$/;
- &transcript("F|$_\n") if $dl>1;
- $filename= $_; s/^l//; s/\.html$//;
- next unless index(lc $_, lc $substrg)>=0;
- &transcript("S|$filename\n") if $dl>0;
- &transcript("S|$out\n") if $dl>0;
- $matches++;
- &sendlynxdocraw("db/pa/$filename","$gBug list for package \`$_'");
- }
- if ($matches) {
- &transcript("$gBug list(s) for $matches package(s) sent.\n\n");
- } else {
- &transcript("No packages found containing \`$substrg'.\n".
- "Use \`index-packages' to get list of packages.\n\n");
- }
- $ok++;
- } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
- &sendlynxdoc("db/ju/unmatched-1.html","junk (this week)");
- } elsif (m/^send-unmatched\s+(last|-1)$/i) {
- &sendlynxdoc("db/ju/unmatched-2.html","junk (last week)");
- } elsif (m/^send-unmatched\s+(old|-2)$/i) {
- &sendlynxdoc("db/ju/unmatched-3.html","junk (two weeks ago)");
- } elsif (m/^getinfo\s+(\S+)$/i) {
- $file= $1;
- if ($file =~ m/^\./ || $file !~ m/^[-.0-9a-z]+$/ || $file =~ m/\.gz$/) {
- &transcript("Filename $file is badly formatted.\n\n");
- } elsif (open(P,"$gDocDir/$file")) {
- $ok++;
- &transcript("Info file $file appears below.\n\n");
- $extras.= "\n---------- Info file $file follows:\n\n";
- while(<P>) { $extras.= $_; }
- close(P);
- } else {
- &transcript("Info file $file does not exist.\n\n");
- }
- } elsif (m/^help$/i) {
- &sendhelp;
- &transcript("\n");
- $ok++;
- } elsif (m/^refcard$/i) {
- &sendtxthelp("bug-mailserver-refcard.txt","mailservers' reference card");
- } elsif (m/^subscribe/i) {
- &transcript(<<END);
-There is no $gProject $gBug mailing list. If you wish to review bug reports
-please do so via http://$gWebUrl/ or ask this mailserver
-to send them to you.
-soon: MAILINGLISTS_TEXT
-END
- } elsif (m/^unsubscribe/i) {
- &transcript(<<END);
-soon: UNSUBSCRIBE_TEXT
-soon: MAILINGLISTS_TEXT
-END
- } elsif (!$control) {
- &transcript(<<END);
-Unknown command or malformed arguments to command.
-(Use control\@$gEmailDomain to manipulate reports.)
-
-END
- if (++$unknowns >= 3) {
- &transcript("Too many unknown commands, stopping here.\n\n");
- last;
- }
- } elsif (m/^close\s+\#?(\d+)$/i) {
- $ok++;
- $ref= $1;
- if ( &setbug ) {
- if(length($s_done)) {
- &transcript("$gBug is already closed, cannot re-close.\n\n");
- &nochangebug;
- } else {
- $action= "$gBug closed, ack sent to submitter - they'd better know why !";
- do {
- CLOSE BUG RECORD
- &addmaintainers($s_package);
- if ( length( $gDoneList ) > 0 && length( $gListDomain ) > 0 )
- { &addccaddress("$gDoneList\@$gListDomain"); }
- $s_done= $replyto;
- @message = @notify_done_email;
- &Debbugs::Email::ProcessTags( \@message, \@BTags, "BTAG" );
- &Debbugs::Email::ProcessTags( \@message, \@LTags, "LTAG" );
- &sendmailmessage( join( "\n", @message), $s_originator );
- Save the bug record
- } while (&getnextbug);
- }
- }
- } elsif (m/^reassign\s+\#?(\d+)\s+(\S.*\S)$/i) {
- $ok++;
- $ref= $1; $newpackage= $2;
- $newpackage =~ y/A-Z/a-z/;
- if (&setbug) {
- if (length($s_package)) {
- $action= "$gBug reassigned from package \`$s_package'".
- " to \`$newpackage'.";
- } else {
- $action= "$gBug assigned to package \`$newpackage'.";
- }
- do {
- &addmaintainers($s_package);
- &addmaintainers($newpackage);
- $s_package= $newpackage;
- } while (&getnextbug);
- }
- } elsif (m/^reopen\s+\#?(\d+)$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(\d+)\s+\=$/i ? ($noriginator='', 1) :
- m/^reopen\s+\#?(\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
- m/^reopen\s+\#?(\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
- $ok++;
- $ref= $1;
- if (&setbug) {
- if (!length($s_done)) {
- &transcript("$gByg is already open, cannot reopen.\n\n");
- &nochangebug;
- } else {
- $action=
- $noriginator eq '' ? "$gBug reopened, originator not changed." :
- "$gBug reopened, originator set to $noriginator.";
- do {
- &addmaintainers($s_package);
- $s_originator= $noriginator eq '' ? $s_originator : $noriginator;
- $s_done= '';
- } while (&getnextbug);
- }
- }
- } elsif (m/^forwarded\s+\#?(\d+)\s+(\S.*\S)$/i) {
- $ok++;
- $ref= $1; $whereto= $2;
- if (&setbug) {
- if (length($s_forwarded)) {
- $action= "Forwarded-to-address changed from $s_forwarded to $whereto.";
- } else {
- $action= "Noted your statement that $gBug has been forwarded to $whereto.";
- }
- if (length($s_done)) {
- $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
- }
- do {
- &addmaintainers($s_package);
- if (length($gFowardList)>0 && length($gListDomain)>0 )
- { &addccaddress("$gFowardList\@$gListDomain"); }
- $s_forwarded= $whereto;
- } while (&getnextbug);
- }
- } elsif (m/^notforwarded\s+\#?(\d+)$/i) {
- $ok++;
- $ref= $1;
- if (&setbug) {
- if (!length($s_forwarded)) {
- &transcript("$gBug is not marked as having been forwarded.\n\n");
- &nochangebug;
- } else {
- $action= "Removed annotation that $gBug had been forwarded to $s_forwarded.";
- do {
- &addmaintainers($s_package);
- $s_forwarded= '';
- } while (&getnextbug);
- }
- }
- } elsif (m/^severity\s+\#?(\d+)\s+([-0-9a-z]+)$/i ||
- m/^priority\s+\#?(\d+)\s+([-0-9a-z]+)$/i) {
- $ok++;
- $ref= $1;
- $newseverity= $2;
- if (!grep($_ eq $newseverity, @severities, "$gDefaultSeverity")) {
- &transcript("Severity level \`$newseverity' is not known.\n".
- "Recognised are: ".join(' ',@showseverities).".\n\n");
- } elsif (&setbug) {
- $printseverity= $s_severity;
- $printseverity= "$gDefaultSeverity" if $printseverity eq '';
- $action= "Severity set to \`$newseverity'.";
- do {
- &addmaintainers($s_package);
- $s_severity= $newseverity;
- } while (&getnextbug);
- }
- } elsif (m/^retitle\s+\#?(\d+)\s+(\S.*\S)\s*$/i) {
- $ok++;
- $ref= $1; $newtitle= $2;
- if (&getbug) {
- &foundbug;
- &addmaintainers($s_package);
- $s_subject= $newtitle;
- $action= "Changed $gBug title.";
- &savebug;
- &transcript("$action\n");
- if (length($s_done)) {
- &transcript("(By the way, that $gBug is currently marked as done.)\n");
- }
- &transcript("\n");
- } else {
- ¬foundbug;
- }
- } elsif (m/^unmerge\s+\#?(\d+)$/i) {
- $ok++;
- $ref= $1;
- if (&setbug) {
- if (!length($s_mergedwith)) {
- &transcript("$gBug is not marked as being merged with any others.\n\n");
- &nochangebug;
- } else {
- $mergelowstate eq 'locked' || die "$mergelowstate ?";
- $action= "Disconnected #$ref from all other report(s).";
- @newmergelist= split(/ /,$s_mergedwith);
- $discref= $ref;
- do {
- &addmaintainers($s_package);
- $s_mergedwith= ($ref == $discref) ? ''
- : join(' ',grep($_ ne $ref,@newmergelist));
- } while (&getnextbug);
- }
- }
- } elsif (m/^merge\s+(\d+(\s+\d+)+)\s*$/i) {
- $ok++;
- @tomerge= sort { $a <=> $b } split(/\s+/,$1);
- @newmergelist= ();
- &getmerge;
- while (defined($ref= shift(@tomerge))) {
- &transcript("D| checking merge $ref\n") if $dl;
- $ref+= 0;
- next if grep($_ eq $ref,@newmergelist);
- if (!&getbug) { ¬foundbug; @newmergelist=(); last }
- &foundbug;
- &transcript("D| adding $ref ($s_mergewith)\n") if $dl;
- $mismatch= '';
- &checkmatch('package','m_package',$s_package);
- &checkmatch('forwarded addr','m_forwarded',$s_forwarded);
- &checkmatch('severity','m_severity',$s_severity);
- &checkmatch('done mark','m_done',length($s_done) ? 'done' : 'open');
- if (length($mismatch)) {
- &transcript("Mismatch - only $Bugs in same state can be merged:\n".
- $mismatch."\n");
- &cancelbug; @newmergelist=(); last;
- }
- push(@newmergelist,$ref);
- push(@tomerge,split(/ /,$s_mergedwith));
- &cancelbug;
- }
- if (@newmergelist) {
- @newmergelist= sort { $a <=> $b } @newmergelist;
- $action= "Merged @newmergelist.";
- for $ref (@newmergelist) {
- &getbug || die "huh ? $gBug $ref disappeared during merge";
- &addmaintainers($s_package);
- $s_mergedwith= join(' ',grep($_ ne $ref,@newmergelist));
- &savebug;
- }
- &transcript("$action\n\n");
- }
- &endmerge;
- } else {
- &transcript("Unknown command or malformed arguments to command.\n\n");
- if (++$unknowns >= 5) {
- &transcript("Too many unknown commands, stopping here.\n\n");
- last;
- }
- }
-}
-if ($procline>$#msg) {
- &transcript(">\nEnd of message, stopping processing here.\n\n");
-}
-if (!$ok) {
- &transcript("No commands successfully parsed; sending the help text(s).\n");
- &sendhelp;
- &transcript("\n");
-}
-
-&transcript("MC\n") if $dl>1;
-@maintccs= ();
-for $maint (keys %maintccreasons) {
-&transcript("MM|$maint|\n") if $dl>1;
- next if $maint eq $replyto;
- $reasonstring= '';
- $reasonsref= $maintccreasons{$maint};
-&transcript("MY|$maint|\n") if $dl>2;
- for $p (sort keys %$reasonsref) {
-&transcript("MP|$p|\n") if $dl>2;
- $reasonstring.= ', ' if length($reasonstring);
- $reasonstring.= $p.' ' if length($p);
- $reasonstring.= join(' ',map("#$_",sort keys %{$$reasonsref{$p}}));
- }
- push(@maintccs,"$maint ($reasonstring)");
- push(@maintccaddrs,"$maint");
-}
-if (@maintccs) {
- &transcript("MC|@maintccs|\n") if $dl>2;
- $maintccs= "Cc: ".join(",\n ",@maintccs)."\n";
-} else { $maintccs = ""; }
-
-$reply= <<END;
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-${maintccs}Subject: Processed: $header{'subject'}
-In-Reply-To: $header{'message-id'}
-References: $header{'message-id'}
-Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
-
-${transcript}Please contact me if you need assistance.
-
-$gMaintainer
-(administrator, $gProject $gBugs database)
-$extras
-END
-
-$repliedshow= join(', ',$replyto,@maintccaddrs);
-&filelock("lock/-1");
-open(AP,">>db/-1.log") || &quit("open db/-1.log: $!");
-print(AP
- "\2\n$repliedshow\n\5\n$reply\n\3\n".
- "\6\n".
- "<strong>Request received</strong> from <code>".
- &sani($header{'from'})."</code>\n".
- "to <code>".&sani($controlrequestaddr)."</code>\n".
- "\3\n".
- "\7\n",@log,"\n\3\n") || &quit("writing db/-1.log: $!");
-close(AP) || &quit("open db/-1.log: $!");
-&unfilelock;
-utime(time,time,"db");
-
-&sendmailmessage($reply,$replyto,@maintccaddrs);
-
-unlink("incoming/P$nn") || &quit("unlinking incoming/P$nn: $!");
-
-sub get_addresses {
- return
- map { $_->address() }
- map { Mail::Address->parse($_) } @_;
-}
-
-sub sendmailmessage {
- local ($message,@recips) = @_;
- print "mailing to >@recips<\n" if $debug;
- $c= open(D,"|-");
- defined($c) || &quit("mailing forking for sendmail: $!");
- if (!$c) { # ie, we are the child process
- exec '/usr/lib/sendmail','-f'."$gMaintainerEmail",'-odi','-oem','-oi',get_addresses(@recips);
- die $!;
- }
- print(D $message) || &quit("writing to sendmail process: $!");
- $!=0; close(D); $? && &quit("sendmail gave exit status $? ($!)");
- $midix++;
-}
-
-sub sendhelp {
- &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
- &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
- if $control;
-}
-
-#sub unimplemented {
-# &transcript("Sorry, command $_[0] not yet implemented.\n\n");
-#}
-
-sub checkmatch {
- local ($string,$mvarname,$svarvalue) = @_;
- local ($mvarvalue);
- if (@newmergelist) {
- eval "\$mvarvalue= \$$mvarname";
- &transcript("D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n")
- if $dl;
- $mismatch .=
- "Values for \`$string' don't match:\n".
- " #$newmergelist[0] has \`$mvarvalue';\n".
- " #$ref has \`$svarvalue'\n"
- if $mvarvalue ne $svarvalue;
- } else {
- &transcript("D| setupmatch \`$string' /$mvarname/$svarvalue/\n")
- if $dl;
- eval "\$$mvarname= \$svarvalue";
- }
-}
-
-# High-level bug manipulation calls
-# Do announcements themselves
-#
-# Possible calling sequences:
-# setbug (returns 0)
-#
-# setbug (returns 1)
-# &transcript(something)
-# nochangebug
-#
-# setbug (returns 1)
-# $action= (something)
-# do {
-# (modify s_* variables)
-# } while (getnextbug);
-
-sub nochangebug {
- &dlen("nochangebug");
- $state eq 'single' || $state eq 'multiple' || die "$state ?";
- &cancelbug;
- &endmerge if $manybugs;
- $state= 'idle';
- &dlex("nochangebug");
-}
-
-sub setbug {
- &dlen("setbug $ref");
- $state eq 'idle' || die "$state ?";
- if (!&getbug) {
- ¬foundbug;
- &dlex("setbug => 0s");
- return 0;
- }
- @thisbugmergelist= split(/ /,$s_mergedwith);
- if (!@thisbugmergelist) {
- &foundbug;
- $manybugs= 0;
- $state= 'single';
- $sref=$ref;
- &dlex("setbug => 1s");
- return 1;
- }
- &cancelbug;
- &getmerge;
- $manybugs= 1;
- if (!&getbug) {
- ¬foundbug;
- &endmerge;
- &dlex("setbug => 0mc");
- return 0;
- }
- &foundbug;
- $state= 'multiple'; $sref=$ref;
- &dlex("setbug => 1m");
- return 1;
-}
-
-sub getnextbug {
- &dlen("getnextbug");
- $state eq 'single' || $state eq 'multiple' || die "$state ?";
- &savebug;
- if (!$manybugs || !@thisbugmergelist) {
- length($action) || die;
- &transcript("$action\n$extramessage\n");
- &endmerge if $manybugs;
- $state= 'idle';
- &dlex("getnextbug => 0");
- return 0;
- }
- $ref= shift(@thisbugmergelist);
- &getbug || die "bug $ref disappeared";
- &foundbug;
- &dlex("getnextbug => 1");
- return 1;
-}
-
-# Low-level bug-manipulation calls
-# Do no announcements
-#
-# getbug (returns 0)
-#
-# getbug (returns 1)
-# cancelbug
-#
-# getmerge
-# $action= (something)
-# getbug (returns 1)
-# savebug/cancelbug
-# getbug (returns 1)
-# savebug/cancelbug
-# [getbug (returns 0)]
-# &transcript("$action\n\n")
-# endmerge
-
-sub notfoundbug { &transcript("$gBug number $ref not found.\n\n"); }
-sub foundbug { &transcript("$gBug#$ref: $s_subject\n"); }
-
-sub getmerge {
- &dlen("getmerge");
- $mergelowstate eq 'idle' || die "$mergelowstate ?";
- &filelock('lock/merge');
- $mergelowstate='locked';
- &dlex("getmerge");
-}
-
-sub endmerge {
- &dlen("endmerge");
- $mergelowstate eq 'locked' || die "$mergelowstate ?";
- &unfilelock;
- $mergelowstate='idle';
- &dlex("endmerge");
-}
-
-sub getbug {
- &dlen("getbug $ref");
- $lowstate eq 'idle' || die "$state ?";
- if (&lockreadbug($ref)) {
- $sref= $ref;
- $lowstate= "open";
- &dlex("getbug => 1");
- $extramessage='';
- return 1;
- }
- $lowstate= 'idle';
- &dlex("getbug => 0");
- return 0;
-}
-
-sub cancelbug {
- &dlen("cancelbug");
- $lowstate eq 'open' || die "$state ?";
- &unfilelock;
- $lowstate= 'idle';
- &dlex("cancelbug");
-}
-
-sub savebug {
- &dlen("savebug $ref");
- $lowstate eq 'open' || die "$lowstate ?";
- length($action) || die;
- $ref == $sref || die "read $sref but saving $ref ?";
- open(L,">>db/$ref.log") || &quit("opening db/$ref.log: $!");
- print(L
- "\6\n".
- "<strong>".&sani($action)."</strong>\n".
- "Request was from <code>".&sani($header{'from'})."</code>\n".
- "to <code>".&sani($controlrequestaddr)."</code>. \n".
- "\3\n".
- "\7\n",@log,"\n\3\n") || &quit("writing db/$ref.log: $!");
- close(L) || &quit("closing db/$ref.log: $!");
- open(S,">db/$ref.status.new") || &quit("opening db/$ref.status.new: $!");
- print(S
- "$s_originator\n".
- "$s_date\n".
- "$s_subject\n".
- "$s_msgid\n".
- "$s_package\n".
- "$s_keywords\n".
- "$s_done\n".
- "$s_forwarded\n".
- "$s_mergedwith\n".
- "$s_severity\n") || &quit("writing db/$ref.status.new: $!");
- close(S) || &quit("closing db/$ref.status.new: $!");
- rename("db/$ref.status.new","db/$ref.status") ||
- &quit("installing new db/$ref.status: $!");
- &unfilelock;
- $lowstate= "idle";
- &dlex("savebug");
-}
-
-sub dlen {
- return if !$dl;
- &transcript("C> @_ ($state $lowstate $mergelowstate)\n");
-}
-
-sub dlex {
- return if !$dl;
- &transcript("R> @_ ($state $lowstate $mergelowstate)\n");
-}
-
-sub transcript {
- print $_[0] if $debug;
- $transcript.= $_[0];
-}
-
-sub sendlynxdoc {
- &sendlynxdocraw;
- &transcript("\n");
- $ok++;
-}
-
-sub sendtxthelp {
- &sendtxthelpraw;
- &transcript("\n");
- $ok++;
-}
-
-sub sendtxthelpraw {
- local ($relpath,$description) = @_;
- $doc='';
- open(D,"$gDocDir/$relpath") || &quit("open doc file $relpath: $!");
- while(<D>) { $doc.=$_; }
- close(D);
- &transcript("Sending $description in separate message.\n");
- &sendmailmessage(<<END.$doc,$replyto);
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-Subject: $gProject $gBug help: $description
-References: $header{'message-id'}
-In-Reply-To: $header{'message-id'}
-Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
-
-END
- $ok++;
-}
-
-sub sendlynxdocraw {
- local ($relpath,$description) = @_;
- $doc='';
- open(L,"lynx -nolist -dump $wwwbase/$relpath 2>&1 |") || &quit("fork for lynx: $!");
- while(<L>) { $doc.=$_; }
- $!=0; close(L);
- if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
- &transcript("Information ($description) is not available -\n".
- "perhaps the $gBug does not exist or is not on the WWW yet.\n");
- $ok++;
- } elsif ($?) {
- &transcript("Error getting $description (code $? $!):\n$doc\n");
- } else {
- &transcript("Sending $description.\n");
- &sendmailmessage(<<END.$doc,$replyto);
-From: $gMaintainerEmail ($gProject $gBug Tracking System)
-To: $replyto
-Subject: $gProject $gBugs information: $description
-References: $header{'message-id'}
-In-Reply-To: $header{'message-id'}
-Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
-
-END
- $ok++;
- }
-}
-
-sub addccaddress {
- my ($cca) = @_;
- $maintccreasons{$cca}{''}{$ref}= 1;
-}
-
-sub addmaintainers
-{ # Data structure is:
- # maintainer email address &c -> assoc of packages -> assoc of bug#'s
- my ($p, $addmaint, $pshow);
- &ensuremaintainersloaded;
- $anymaintfound=0; $anymaintnotfound=0;
- for $p (split(m/[ \t?,()]+/,$_[0]))
- { $p =~ y/A-Z/a-z/;
- $pshow= ($p =~ m/[-+.a-z0-9]+/ ? $& : '');
- if (defined($maintainerof{$p}))
- { $addmaint= $maintainerof{$p};
- &transcript("MR|$addmaint|$p|$ref|\n") if $dl>2;
- $maintccreasons{$addmaint}{$p}{$ref}= 1;
- print "maintainer add >$p|$addmaint<\n" if $debug;
- } else { print "maintainer none >$p<\n" if $debug; }
- }
-}
-
-sub ensuremaintainersloaded {
- my ($a,$b);
- return if $maintainersloaded++;
- open(MAINT,"$gMaintainerFile") || die &quit("maintainers open: $!");
- while (<MAINT>) {
- m/^(\S+)\s+(\S.*\S)\n$/ || &quit("maintainers bogus \`$_'");
- $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
- $maintainerof{$1}= $2;
- }
- close(MAINT);
-}
-
-sub syntax {
- print "$BANNER\n";
- print <<"EOT-EOT-EOT";
-Syntax: $FILE [options]
- -c, --config CFGFILE read CFGFILE for configuration (default=./debvote.cfg)
- -h, --help display this help text
- -v, --verbose verbose messages
- -q, --quiet cancels verbose in a config file
- -V, --version display Debvote version and exit
- -d, --debug turn debug messages ON (multiple -d for more verbose)
-EOT-EOT-EOT
-
- exit $_[0];
-}
- 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)
- Dissallow forwarded being set to a $gEmailDomain address
(closes: #397486)
- Fix broken sorting by usertags by forcing numeric (closes: #395027)
+ - Add support for hiding useless messages; thanks to Sune Vuorela.
+ (closes: #406020)
+ - Fix arrayrefs leaking into the myurl function (closes: #397344)
+ - List bugs being blocked (closes: #356680)
+ - Fix multiple submitters for a single bug in the index
+ (closes: #402362)
+ - Marking a bug as fixed now overrides a found at that exact version
+ (closes: #395865)
-- Colin Watson <cjwatson@debian.org> Fri, 20 Jun 2003 18:57:25 +0100
Source: debbugs
Section: misc
-Priority: optional
+Priority: extra
Maintainer: Debbugs developers <debian-debbugs@lists.debian.org>
Uploaders: Josip Rodin <joy-packages@debian.org>, Colin Watson <cjwatson@debian.org>
Standards-Version: 3.2.1
-Build-Depends-Indep: debhelper
+Build-Depends-Indep: debhelper, libparams-validate-perl, libmailtools-perl, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl, libcgi-simple-perl, libhttp-server-simple-perl, libtest-www-mechanize-perl
Package: debbugs
Architecture: all
-Depends: perl5 | perl, exim4 | mail-transport-agent, libmailtools-perl, ed, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl
-Recommends: httpd, links | lynx
-Suggests: spamassassin (>= 3.0)
+Depends: perl5 | perl, exim4 | mail-transport-agent, libmailtools-perl, ed, libmime-perl, libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl, libcgi-simple-perl, libparams-validate-perl
+Recommends: apache | httpd, links | lynx
+Suggests: spamassassin (>= 3.0), libcgi-alert-perl
Description: The bug tracking system based on the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
users and developers. Each bug is given a number, and is kept on file until
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
-#!/bin/sh
-
-set -e
-if [ $# != 1 ]; then echo >&2 'need version'; exit 1; fi
-version="$1"; shift
-tag="`echo \"release-$version\" | sed -e 's/\./-/g'`"
-cvs -Q tag -F "$tag"
-
-cd ..
-rm -rf bugs-export-temp$$ "debbugs-$version"
-rm -f "debbugs-$version.tar" "debbugs-$version.tar.gz"
-mkdir bugs-export-temp$$
-cd bugs-export-temp$$
-
-cvs -Q co -r "$tag" bugsdb
-mv bugsdb "../debbugs-$version"
-cd ..
-rm -rf bugs-export-temp$$
-
-tar --exclude CVS \
- --exclude ncipher \
- --exclude '*.out' \
- --exclude '*.trace' \
- --exclude '*.new' \
- --exclude '*~' \
- --exclude 'trace' \
- -cf "debbugs-$version.tar" "debbugs-$version"
-gzip -9 "debbugs-$version.tar"
-rm -rf "debbugs-$version"
-echo "../debbugs-$version.tar.gz created."
--- /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
the $gBug is cleared. This is identical to the behaviour of
<code>reopen</code>.
+ <p>This command will only cause a bug to be marked as not done if no
+ version is specified, or if the <var>version</var> being marked found
+ is equal to the <var>version</var> which was last marked fixed. (If
+ you are certain that you want the bug marked as not done,
+ use <code>reopen</code> in conjunction with <code>found</code>.</p>
+
<p>This command was introduced in preference to <code>reopen</code>
because it was difficult to add a <var>version</var> to that command's
syntax without suffering ambiguity.
<dt><code>owner</code> <var>bugnumber</var> <var>address</var> | <code>!</code>
<dd>Sets <var>address</var> to be the "owner" of #<var>bugnumber</var>.
- The owner of a $gBug claims responsibility for fixing it and will receive
- all mail regarding it. This is useful to share out work in cases where a
+ The owner of a $gBug claims responsibility for fixing it.
+ This is useful to share out work in cases where a
package has a team of maintainers.
<p>If you wish to become the owner of the $gBug yourself, you can use the
# 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
# -*- perl -*-
-# $Id: errorlib.in,v 1.52 2005/10/06 03:46:13 ajt Exp $
use Mail::Address;
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
-use Debbugs::Packages;
-
-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;
-}
+use Debbugs::Packages qw(:all);
+use Debbugs::Common qw(:all);
+use Debbugs::Status qw(:all);
+use Carp;
sub unlockreadbugmerge {
local ($rv) = @_;
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}};
- }
-}
-
-=head2 removefoundversions
-
- removefoundversions($data,$package,$versiontoremove)
-
-Removes found versions from $data
-
-If a version is fully qualified (contains /) only versions matching
-exactly are removed. Otherwise, all versions matching the version
-number are removed.
-
-Currently $package and $isbinary are entirely ignored, but accepted
-for backwards compatibilty.
-
-=cut
-
-sub removefoundversions {
- my $data = shift;
- my $package = shift;
- my $version = shift;
- my $isbinary = shift;
- return unless defined $version;
-
- foreach my $ver (split /[,\s]+/, $version) {
- if ($ver =~ m{/}) {
- # fully qualified version
- @{$data->{found_versions}} =
- grep {$_ ne $ver}
- @{$data->{found_versions}};
- }
- else {
- # non qualified version; delete all matchers
- @{$data->{found_versions}} =
- grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
- @{$data->{found_versions}};
- }
- }
-}
-
-sub addfixedversions {
- my $data = shift;
- my $package = shift;
- my $version = shift;
- my $isbinary = shift;
- return unless defined $version;
- undef $package if $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) = @_;
+ carp "You should be using HTML::Entities instead.";
+ $in =~ s/([<>&"])/$saniarray{$1}/g;
+ return $in;
}
sub getmailbody {
return \@log;
}
-sub isstrongseverity {
- my $severity = shift;
- $severity = $gDefaultSeverity if $severity eq '';
- return grep { $_ eq $severity } @gStrongSeverities;
-}
-
-
@severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
@showseverities= @severities;
grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
# Copyright (c) 2005/08/03 Anthony Towns
# GPL v2
-#use strict;
-
use DB_File;
use MLDBM qw(DB_FILE Storable);
use Fcntl qw/O_RDWR O_CREAT O_TRUNC/;
pod2usage(1) if $options{help};
pod2usage(-verbose=>2) if $options{man};
-{ no warnings;
- no strict;
-require '/etc/debbugs/config';
-require '/org/bugs.debian.org/scripts/errorlib';
-}
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(getparsedaddrs getbugcomponent);
+use Debbugs::Status qw(readbug);
-chdir('/org/bugs.debian.org/spool') or die "chdir spool: $!\n";
+chdir($config{spool_dir}) or die "chdir $config{spool_dir} failed: $!";
my $verbose = $options{debug};
-my $indexdest = $options{index_path} || "/org/bugs.debian.org/spool";
+my $indexdest = $options{index_path} || $config{spool_dir};
my $initialdir = "db-h";
my $suffix = "";
}
# NB: The reverse index is special; it's used to clean up during updates to bugs
-my @indexes = ('package', 'tag', 'severity', 'submitter-email','reverse');
+my @indexes = ('package', 'tag', 'severity','owner','submitter-email','reverse');
my $indexes;
my %slow_index = ();
my %fast_index = ();
addbugtoindex("package", $bug, split /[\s,]+/, $fdata->{"package"});
addbugtoindex("tag", $bug, split /[\s,]+/, $fdata->{"keywords"});
addbugtoindex('submitter-email', $bug,
- emailfromrfc822($fdata->{"originator"}));
+ map {$_->address} getparsedaddrs($fdata->{originator}));
addbugtoindex("severity", $bug, $fdata->{"severity"});
+ addbugtoindex("owner", $bug, $fdata->{"owner"});
}
}
# 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");
}
+
# Usage: process nn
# Temps: incoming/Pnn
-use POSIX qw(strftime tzset);
-$ENV{"TZ"} = 'UTC';
-tzset();
+use POSIX qw(strftime);
use MIME::Parser;
use Debbugs::MIME qw(decode_rfc1522 create_mime_message);
use Debbugs::Packages qw(getpkgsrc);
use Debbugs::User qw(read_usertags write_usertags);
-my $config_path = '/etc/debbugs';
-my $lib_path = '/usr/lib/debbugs';
+use HTML::Entities qw(encode_entities);
# TODO DLA; needs config reworking and errorlib reworking
# use warnings;
# use strict;
-require "$config_path/config";
+use Debbugs::Status qw(:versions);
+use Debbugs::Config qw(:globals);
+my $lib_path = $gLibPath;
+
require "$lib_path/errorlib";
$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
print DEBUG ">$fn|$fv|\n";
$fn = lc $fn;
# Don't lc owner or forwarded
- $fv = lc $fv unless $fh =~ /^(?:owner|forwarded|usertags)$/;
+ $fv = lc $fv unless $fh =~ /^(?:owner|forwarded|usertags|version|source-version)$/;
$pheader{$fn} = $fv;
print DEBUG ">$fn~$fv<\n";
}
&htmllog($newref ? "Report" : "Information", "forwarded",
join(', ',"$gSubmitList\@$gListDomain",@resentccs),
"<code>$gBug#$ref</code>".
- (length($data->{package})? "; Package <code>".&sani($data->{package})."</code>" : '').
+ (length($data->{package})? "; Package <code>".encode_entities($data->{package})."</code>" : '').
".");
&sendmessage(<<END,["$gSubmitList\@$gListDomain",@resentccs],[@bccs]);
Subject: $gBug#$ref: $newsubject
&htmllog($newref ? "Report" : "Information", "forwarded",
$resentccval,
"<code>$gBug#$ref</code>".
- (length($data->{package}) ? "; Package <code>".&sani($data->{package})."</code>" : '').
+ (length($data->{package}) ? "; Package <code>".encode_entities($data->{package})."</code>" : '').
".");
} else {
&htmllog($newref ? "Report" : "Information", "stored",
"",
"<code>$gBug#$ref</code>".
- (length($data->{package}) ? "; Package <code>".&sani($data->{package})."</code>" : '').
+ (length($data->{package}) ? "; Package <code>".encode_entities($data->{package})."</code>" : '').
".");
}
&sendmessage(<<END,[@resentccs],[@bccs]);
END
}
-$htmlbreak= length($brokenness) ? "<p>\n".
&sani($brokenness)."\n<p>\n" : '';
+$htmlbreak= length($brokenness) ? "<p>\n".
encode_entities($brokenness)."\n<p>\n" : '';
$htmlbreak =~ s/\n\n/\n<P>\n\n/g;
if (length($resentccval)) {
- $htmlbreak = " Copy sent to <code>".&sani($resentccval)."</code>.".
+ $htmlbreak = " Copy sent to <code>".encode_entities($resentccval)."</code>.".
$htmlbreak;
}
unless (exists $header{'x-debbugs-no-ack'}) {
print(AP
"\6\n".
"<strong>$whatobj $whatverb</strong>".
- ($where eq '' ? "" : " to <code>".&sani($where)."</code>").
+ ($where eq '' ? "" : " to <code>".encode_entities($where)."</code>").
":<br>\n". $desc.
"\n\3\n") || &quit("writing db-h/$hash/$ref.log (lh): $!");
close(AP) || &quit("closing db-h/$hash/$ref.log (lh): $!");
# Creates: incoming/E.nn
# Stop: stop
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
+use warnings;
+use strict;
-require "$config_path/config";
-require "$lib_path/errorlib";
-$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
+
+use Debbugs::Config qw(:globals);
+use Debbugs::Common qw(:lock);
+
+my $lib_path = $gLibPath;
use File::Path;
chdir( $gSpoolDir ) || die "chdir spool: $!\n";
-push( @INC, $lib_path );
#open(DEBUG,">&4");
umask(002);
$|=1;
-undef %fudged;
+my %fudged;
+my @ids;
+my $ndone = 0;
&filelock('incoming-cleaner');
for (;;) {
if (-f 'stop') {
@ids= sort(@ids);
}
stat("$gMaintainerFile") || die "stat $gMaintainerFile: $!\n";
- $nf= @ids;
- $id= shift(@ids);
+ my $nf= @ids;
+ my $id= shift(@ids);
unless (rename("incoming/I$id","incoming/G$id")) {
if ($fudged{$id}) {
die "$id already fudged once! $!\n";
$fudged{$id}= 1;
next;
}
+ my $c;
if ($id =~ m/^[RC]/) {
- print(STDOUT "[$nf] $id service ...") || die $!;
+ print(STDOUT "[$nf] $id service ...") || die $!;
defined($c=fork) || die $!;
- if (!$c) { exec("$lib_path/service",$id); die $!; }
+ if (!$c) { exec("$lib_path/service",$id); die "unable to execute $lib_path/service: $!"; }
} elsif ($id =~ m/^[BMQFDUL]/) {
print(STDOUT "[$nf] $id process ...") || die $!;
defined($c=fork) || die $!;
- if (!$c) { exec("$lib_path/process",$id); die $!; }
+ if (!$c) { exec("$lib_path/process",$id); die "unable to execute $lib_path/process: $!"; }
} else {
die "bad name $id";
}
- $cc=waitpid($c,0); $cc == $c || die "$cc $c $!";
- $status=$?;
+ my $cc=waitpid($c,0); $cc == $c || die "$cc $c $!";
+ my $status=$?;
if ($status) {
print(STDERR "$id: process failed ($status $!) - now in [PG]$id\n") || die $!;
}
#set umask in order to have group-writable incoming/*
#umask(002);
-#load configuration file
-$config_path = '/etc/debbugs';
-#$lib_path = '/usr/lib/debbugs';
+use Debbugs::Config qw(:globals :text);
+my $lib_path = $gLibPath;
-require "$config_path/config";
$ENV{'PATH'} = '/usr/lib/debbugs:'.$ENV{'PATH'};
#set source of mail delivery
s/\>//;
s/\<//;
}
-require("/etc/debbugs/text");
#remove everything from @ to end of line
s/\@.*$//;
use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
use Debbugs::Mail qw(send_mail_message);
use Debbugs::User;
+use HTML::Entities qw(encode_entities);
-$config_path = '/etc/debbugs';
-$lib_path = '/usr/lib/debbugs';
-
-require "$config_path/config";
+use Debbugs::Config qw(:globals);
+$lib_path = $gLibPath;
require "$lib_path/errorlib";
$ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
$bug_affected{$ref}=1;
if (&setbug) {
if (@{$data->{fixed_versions}}) {
- &transcript("'reopen' is deprecated when a bug has been closed with a version;\nuse 'found' or 'submitter' as appropriate instead.\n");
+ &transcript("'reopen' may be inappropriate when a bug has been closed with a version;\nyou may need to use 'found' to remove fixed versions.\n");
}
if (!length($data->{done})) {
&transcript("$gBug is already open, cannot reopen.\n\n");
$ref = $clonebugs{$ref};
}
if (&getbug) {
+ &foundbug;
push @okayblockers, $ref;
# add to the list all bugs that are merged with $b,
"\2\n$repliedshow\n\5\n$reply\n\3\n".
"\6\n".
"<strong>Request received</strong> from <code>".
- &sani($header{'from'})."</code>\n".
- "to <code>".&sani($controlrequestaddr)."</code>\n".
+ encode_entities($header{'from'})."</code>\n".
+ "to <code>".encode_entities($controlrequestaddr)."</code>\n".
"\3\n".
"\7\n",@{escapelog(@log)},"\n\3\n") || &quit("writing db-h/-1.log: $!");
close(AP) || &quit("open db-h/-1.log: $!");
open(L,">>db-h/$hash/$ref.log") || &quit("opening db-h/$hash/$ref.log: $!");
print(L
"\6\n".
- "<strong>".&sani($action)."</strong>\n".
- "Request was from <code>".&sani($header{'from'})."</code>\n".
- "to <code>".&sani($controlrequestaddr)."</code>. \n".
+ "<strong>".encode_entities($action)."</strong>\n".
+ "Request was from <code>".encode_entities($header{'from'})."</code>\n".
+ "to <code>".encode_entities($controlrequestaddr)."</code>. \n".
"\3\n".
"\7\n",@{escapelog(@log)},"\n\3\n") || &quit("writing db-h/$hash/$ref.log: $!");
close(L) || &quit("closing db-h/$hash/$ref.log: $!");
-# $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
--- /dev/null
+# -*- mode: cperl;-*-
+
+use Test::More tests => 1;
+
+use warnings;
+use strict;
+
+use utf8;
+use Encode;
+
+use_ok('Debbugs::Packages');
+
);
-require_ok('scripts/errorlib.in');
+use_ok('Debbugs::Status',qw(:versions));
# check removefoundversions
my $data = dclone(\%data);
removefoundversions($data,$data->{package},'1.00');
--- /dev/null
+# -*- mode: cperl;-*-
+# $Id: 05_mail.t,v 1.1 2005/08/17 21:46:17 don Exp $
+
+use Test::More tests => 31;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+use Data::Dumper;
+
+# HTTP::Server:::Simple defines a SIG{CHLD} handler that breaks system; undef it here.
+$SIG{CHLD} = sub {};
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+my $sendmail_dir = $config{sendmail_dir};
+my $spool_dir = $config{spool_dir};
+my $config_dir = $config{config_dir};
+
+END{
+ if ($ENV{DEBUG}) {
+ diag("spool_dir: $spool_dir\n");
+ diag("config_dir: $config_dir\n");
+ diag("sendmail_dir: $sendmail_dir\n");
+ }
+}
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submiting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+# now we check to see that we have a bug, and nextnumber has been incremented
+ok(-e "$spool_dir/db-h/01/1.log",'log file created');
+ok(-e "$spool_dir/db-h/01/1.summary",'sumary file created');
+ok(-e "$spool_dir/db-h/01/1.status",'status file created');
+ok(-e "$spool_dir/db-h/01/1.report",'report file created');
+
+# next, we check to see that (at least) the proper messages have been
+# sent out. 1) ack to submitter 2) mail to maintainer
+
+# This keeps track of the previous size of the sendmail directory
+my $SD_SIZE_PREV = 0;
+my $SD_SIZE_NOW = dirsize($sendmail_dir);
+ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 2,'submit messages appear to have been sent out properly');
+$SD_SIZE_PREV=$SD_SIZE_NOW;
+
+# now send a message to the bug
+
+send_message(to => '1@bugs.something',
+ headers => [To => '1@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Sending a message to a bug',
+ ],
+ body => <<EOF) or fail('sending message to 1@bugs.someting failed');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+$SD_SIZE_NOW = dirsize($sendmail_dir);
+ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 2,'1@bugs.something messages appear to have been sent out properly');
+$SD_SIZE_PREV=$SD_SIZE_NOW;
+
+# just check to see that control doesn't explode
+send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Munging a bug',
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+severity 1 wishlist
+retitle 1 new title
+thanks
+EOF
+
+$SD_SIZE_NOW = dirsize($sendmail_dir);
+ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 1,'control@bugs.something messages appear to have been sent out properly');
+$SD_SIZE_PREV=$SD_SIZE_NOW;
+# now we need to check to make sure the control message was processed without errors
+ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug")) == 0,
+ 'control@bugs.something message was parsed without errors');
+# now we need to check to make sure that the control message actually did anything
+# This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
+eval "use Debbugs::Status qw(read_bug);";
+my $status = read_bug(bug=>1);
+ok($status->{subject} eq 'new title','bug 1 retitled');
+ok($status->{severity} eq 'wishlist','bug 1 wishlisted');
+
+# now we're going to go through and methododically test all of the control commands.
+my @control_commands =
+ (severity_wishlist => {command => 'severity',
+ value => 'wishlist',
+ status_key => 'severity',
+ status_value => 'wishlist',
+ },
+ 'found_1.0' => {command => 'found',
+ value => '1.0',
+ status_key => 'found_versions',
+ status_value => ['1.0'],
+ },
+ 'notfound_1.0' => {command => 'notfound',
+ value => '1.0',
+ status_key => 'found_versions',
+ status_value => [],
+ },
+ submitter_foo => {command => 'submitter',
+ value => 'foo@bar.com',
+ status_key => 'originator',
+ status_value => 'foo@bar.com',
+ },
+
+ forwarded_foo => {command => 'forwarded',
+ value => 'foo@bar.com',
+ status_key => 'forwarded',
+ status_value => 'foo@bar.com',
+ },
+ owner_foo => {command => 'owner',
+ value => 'foo@bar.com',
+ status_key => 'owner',
+ status_value => 'foo@bar.com',
+ },
+ noowner => {command => 'noowner',
+ value => '',
+ status_key => 'owner',
+ status_value => '',
+ },
+
+ );
+
+while (my ($command,$control_command) = splice(@control_commands,0,2)) {
+ # just check to see that control doesn't explode
+ $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
+ and $control_command->{value} !~ /^\s/;
+ send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => "Munging a bug with $command",
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+$control_command->{command} 1$control_command->{value}
+thanks
+EOF
+ ;
+ $SD_SIZE_NOW = dirsize($sendmail_dir);
+ ok($SD_SIZE_NOW-$SD_SIZE_PREV >= 1,'control@bugs.something messages appear to have been sent out properly');
+ $SD_SIZE_PREV=$SD_SIZE_NOW;
+ # now we need to check to make sure the control message was processed without errors
+ ok(system('sh','-c','find '.$sendmail_dir.q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")) == 0,
+ 'control@bugs.something'. "$command message was parsed without errors");
+ # now we need to check to make sure that the control message actually did anything
+ my $status = read_bug(bug=>1);
+ is_deeply($status->{$control_command->{status_key}},$control_command->{status_value},"bug 1 $command")
+ or fail(Dumper($status));
+}
--- /dev/null
+# -*- mode: cperl;-*-
+
+
+use Test::More tests => 3;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+use Test::WWW::Mechanize;
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+# Output some debugging information if there's an error
+END{
+ if ($ENV{DEBUG}) {
+ foreach my $key (keys %config) {
+ diag("$key: $config{$key}\n");
+ }
+ }
+}
+
+# create a bug
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submitting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+
+# test bugreport.cgi
+
+# start up an HTTP::Server::Simple
+my $bugreport_cgi_handler = sub {
+ # I do not understand why this is necessary.
+ $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config";
+ my $content = qx(perl -I. -T cgi/bugreport.cgi);
+ $content =~ s/^\s*Content-Type:[^\n]+\n*//si;
+ print $content;
+};
+
+my $port = 11342;
+
+ok(DebbugsTest::HTTPServer::fork_and_create_webserver($bugreport_cgi_handler,$port),
+ 'forked HTTP::Server::Simple successfully');
+
+my $mech = Test::WWW::Mechanize->new();
+
+$mech->get_ok('http://localhost:'.$port.'/?bug=1',
+ 'Page received ok');
+ok($mech->content() =~ qr/\<title\>\#1\s+\-\s+Submitting a bug/i,
+ 'Title of bug is submitting a bug');
+
+# Other tests for bugs in the page should be added here eventually
--- /dev/null
+# -*- mode: cperl;-*-
+
+
+use Test::More tests => 3;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+use Test::WWW::Mechanize;
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:all);
+
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+# Output some debugging information if there's an error
+END{
+ if ($ENV{DEBUG}) {
+ foreach my $key (keys %config) {
+ diag("$key: $config{$key}\n");
+ }
+ }
+}
+
+# create a bug
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submitting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+
+# test bugreport.cgi
+
+# start up an HTTP::Server::Simple
+my $pkgreport_cgi_handler = sub {
+ # I do not understand why this is necessary.
+ $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config";
+ # We cd here because pkgreport uses require ./common.pl
+ my $content = qx(cd cgi; perl -I.. -T pkgreport.cgi);
+ # Strip off the Content-Type: stuff
+ $content =~ s/^\s*Content-Type:[^\n]+\n*//si;
+ print $content;
+};
+
+my $port = 11342;
+
+ok(DebbugsTest::HTTPServer::fork_and_create_webserver($pkgreport_cgi_handler,$port),
+ 'forked HTTP::Server::Simple successfully');
+
+
+my $mech = Test::WWW::Mechanize->new(autocheck => 1);
+
+$mech->get_ok('http://localhost:'.$port.'/?pkg=foo');
+
+# I'd like to use $mech->title_ok(), but I'm not sure why it doesn't
+# work.
+ok($mech->content()=~ qr/package foo/i,
+ 'Package title seems ok',
+ );
+
+# Test more stuff here
--- /dev/null
+
+package DebbugsTest;
+
+=head1 NAME
+
+DebbugsTest
+
+=head1 SYNOPSIS
+
+use DebbugsTest
+
+
+=head1 DESCRIPTION
+
+This module contains various testing routines used to test debbugs in
+a "pseudo install"
+
+=head1 FUNCTIONS
+
+=cut
+
+use warnings;
+use strict;
+use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
+use base qw(Exporter);
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+use IPC::Open3;
+use IO::Handle;
+
+use Params::Validate qw(validate_with :types);
+
+BEGIN{
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(qw(configuration));
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+
+
+sub create_debbugs_configuration {
+ my %param = validate_with(params => \@_,
+ spec => {debug => {type => BOOLEAN,
+ default => 0,
+ },
+ cleanup => {type => BOOLEAN,
+ optional => 1,
+ },
+ },
+ );
+ $param{cleanup} = $param{debug}?0:1 if not exists $param{cleanup};
+ my $sendmail_dir = tempdir(CLEANUP => $param{cleanup});
+ my $spool_dir = tempdir(CLEANUP => $param{cleanup});
+ my $config_dir = tempdir(CLEANUP => $param{cleanup});
+
+
+ $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config";
+ $ENV{PERL5LIB} = getcwd();
+ $ENV{SENDMAIL_TESTDIR} = $sendmail_dir;
+ my $sendmail_tester = getcwd().'/t/sendmail_tester';
+ unless (-x $sendmail_tester) {
+ die q(t/sendmail_tester doesn't exist or isn't executable. You may be in the wrong directory.);
+ }
+ my %files_to_create = ("$config_dir/debbugs_config" => <<END,
+\$gSendmail='$sendmail_tester';
+\$gSpoolDir='$spool_dir';
+\$gLibPath='@{[getcwd()]}/scripts';
+1;
+END
+ "$spool_dir/nextnumber" => qq(1\n),
+ "$config_dir/Maintainers" => qq(foo Blah Bleargh <bar\@baz.com>\n),
+ "$config_dir/Maintainers.override" => qq(),
+ "$config_dir/indices/sources" => <<END,
+foo main foo
+END
+ "$config_dir/pseudo-packages.description" => '',
+ );
+ while (my ($file,$contents) = each %files_to_create) {
+ system('mkdir','-p',dirname($file));
+ my $fh = IO::File->new($file,'w') or
+ die "Unable to create $file: $!";
+ print {$fh} $contents or die "Unable to write $contents to $file: $!";
+ close $fh or die "Unable to close $file: $!";
+ }
+
+ system('touch',"$spool_dir/index.db.realtime");
+ system('ln','-s','index.db.realtime',
+ "$spool_dir/index.db");
+ system('touch',"$spool_dir/index.archive.realtime");
+ system('ln','-s','index.archive.realtime',
+ "$spool_dir/index.archive");
+
+ # create the spool files and sub directories
+ map {system('mkdir','-p',"$spool_dir/$_"); }
+ map {('db-h/'.$_,'archive/'.$_)}
+ map { sprintf "%02d",$_ % 100} 0..99;
+ system('mkdir','-p',"$spool_dir/incoming");
+ system('mkdir','-p',"$spool_dir/lock");
+
+ return (spool_dir => $spool_dir,
+ sendmail_dir => $sendmail_dir,
+ config_dir => $config_dir,
+ );
+}
+
+sub dirsize{
+ my ($dir) = @_;
+ opendir(DIR,$dir);
+ my @content = grep {!/^\.\.?$/} readdir(DIR);
+ closedir(DIR);
+ return scalar @content;
+}
+
+
+# We're going to use create mime message to create these messages, and
+# then just send them to receive.
+# First, check that submit@ works
+
+sub send_message{
+ my %param = validate_with(params => \@_,
+ spec => {to => {type => SCALAR,
+ default => 'submit@bugs.something',
+ },
+ headers => {type => ARRAYREF,
+ },
+ body => {type => SCALAR,
+ },
+ run_processall =>{type => BOOLEAN,
+ default => 1,
+ },
+ }
+ );
+ $ENV{LOCAL_PART} = $param{to};
+ my ($rfd,$wfd);
+ my $output='';
+ local $SIG{PIPE} = 'IGNORE';
+ local $SIG{CHLD} = sub {};
+ my $pid = open3($wfd,$rfd,$rfd,'scripts/receive.in')
+ or die "Unable to start receive.in: $!";
+ print {$wfd} create_mime_message($param{headers},
+ $param{body}) or die "Unable to to print to receive.in";
+ close($wfd) or die "Unable to close receive.in";
+ my $err = $? >> 8;
+ my $childpid = waitpid($pid,0);
+ if ($childpid != -1) {
+ $err = $? >> 8;
+ print STDERR "receive.in pid: $pid doesn't match childpid: $childpid\n" if $childpid != $pid;
+ }
+ if ($err != 0 ) {
+ my $rfh = IO::Handle->new_from_fd($rfd,'r') or die "Unable to create filehandle: $!";
+ $rfh->blocking(0);
+ my $rv;
+ while ($rv = $rfh->sysread($output,1000,length($output))) {}
+ if (not defined $rv) {
+ print STDERR "Reading from STDOUT/STDERR would have blocked.";
+ }
+ print STDERR $output,qq(\n);
+ die "receive.in failed with exit status $err";
+ }
+ # now we should run processall to see if the message gets processed
+ if ($param{run_processall}) {
+ system('scripts/processall.in') == 0 or die "processall.in failed";
+ }
+}
+
+{
+ package DebbugsTest::HTTPServer;
+ use base qw(HTTP::Server::Simple::CGI);
+
+ our $child_pid = undef;
+ our $webserver = undef;
+ our $server_handler = undef;
+
+ END {
+ if (defined $child_pid) {
+ # stop the child
+ kill(15,$child_pid);
+ waitpid(-1,0);
+ }
+ }
+
+ sub fork_and_create_webserver {
+ my ($handler,$port) = @_;
+ $port ||= 8080;
+ if (defined $child_pid) {
+ die "We appear to have already forked once";
+ }
+ $server_handler = $handler;
+ my $pid = fork;
+ return 0 if not defined $pid;
+ if ($pid) {
+ $child_pid = $pid;
+ # Wait here for a second to let the child start up
+ sleep 1;
+ return $pid;
+ }
+ else {
+ $webserver = DebbugsTest::HTTPServer->new($port);
+ $webserver->run;
+ }
+
+ }
+
+ sub handle_request {
+ if (defined $server_handler) {
+ $server_handler->(@_);
+ }
+ else {
+ warn "No handler defined\n";
+ print "No handler defined\n";
+ }
+ }
+}
+
+
+1;
+
+__END__
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+# All this script does is write whatever is piped to it to a unique
+# filename, with the first line containing the arguments sent.
+
+use IO::File;
+
+# create a unique filename
+if (not -d $ENV{SENDMAIL_TESTDIR}) {
+ system('mkdir','-p',$ENV{SENDMAIL_TESTDIR});
+}
+
+my $fn = "$ENV{SENDMAIL_TESTDIR}/".time.$$;
+
+my $fh = IO::File->new($fn ,'w') or die "Unable to open file $fn for writing: $!";
+
+print {$fh} "$0 called with: ", join(' ',map {"'$_'"} @ARGV) or die "Unable to write to file $fn: $!";
+print {$fh} "\n\n";
+print {$fh} <STDIN> or die "Unable to write to file $fn: $!";
+
+close $fh or die "Unable to close file $fn: $!";
projects / debbugs.git / commitdiff