# -*- perl -*-
-# $Id: errorlib.in,v 1.10 2002/10/27 13:40:17 ajt Exp $
+# $Id: errorlib.in,v 1.43 2005/07/17 16:06:26 cjwatson Exp $
+
+use Mail::Address;
+use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
sub F_SETLK { 6; } sub F_WRLCK{ 1; }
$flockstruct= 'sslll'; # And there ought to be something for this too.
}
sub lockreadbugmerge {
- local ($lref) = @_;
- if (!&lockreadbug($lref)) { return 0; }
- if (!length($s_mergedwith)) { return 1; }
+ local ($lref, $location) = @_;
+ local $data;
+ if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
+ if (!length($data{mergedwith})) { return ( 1, $data ); }
&unfilelock;
&filelock('lock/merge');
- if (!&lockreadbug($lref)) { &unfilelock; return 0; }
- return 2;
+ if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
+ 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',
+ );
+
+# 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) = @_;
+ local ($lref, $location) = @_;
&filelock("lock/$lref");
- my $hash = get_hashname($lref);
- if (!open(S,"db-h/$hash/$lref.status")) { &unfilelock; return 0; }
- chop($s_originator= <S>);
- chop($s_date= <S>);
- chop($s_subject= <S>);
- chop($s_msgid= <S>);
- chop($s_package= <S>);
- chop($s_keywords= <S>);
- chop($s_done= <S>);
- chop($s_forwarded= <S>);
- chop($s_mergedwith= <S>);
- chop($s_severity= <S>);
- close(S);
- $s_severity = 'normal' if $s_severity eq '';
- return 1;
+ 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 {
}
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: $!";
- unlink($lockfile) || warn "failed to remove lock file: $!";
+ 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 $source = shift;
+ my $version = shift;
+ return unless defined $version;
+ undef $source if $source =~ m[(?:\s|/)];
+
+ foreach my $ver (split /[,\s]+/, $version) {
+ $ver = "$source/$ver" if defined $source;
+ unless (grep { $_ eq $ver } @{$data->{found_versions}}) {
+ push @{$data->{found_versions}}, $ver;
+ }
+ @{$data->{fixed_versions}} =
+ grep { $_ ne $ver } @{$data->{fixed_versions}};
+ }
+}
+
+sub removefoundversions {
+ my $data = shift;
+ my $source = shift;
+ my $version = shift;
+ return unless defined $version;
+ undef $source if $source =~ m[(?:\s|/)];
+
+ foreach my $ver (split /[,\s]+/, $version) {
+ $ver = "$source/$ver" if defined $source;
+ @{$data->{found_versions}} =
+ grep { $_ ne $ver } @{$data->{found_versions}};
+ }
+}
+
+sub addfixedversions {
+ my $data = shift;
+ my $source = shift;
+ my $version = shift;
+ return unless defined $version;
+ undef $source if $source =~ m[(?:\s|/)];
+
+ foreach my $ver (split /[,\s]+/, $version) {
+ $ver = "$source/$ver" if defined $source;
+ unless (grep { $_ eq $ver } @{$data->{fixed_versions}}) {
+ push @{$data->{fixed_versions}}, $ver;
+ }
+ @{$data->{found_versions}} =
+ grep { $_ ne $ver } @{$data->{found_versions}};
+ }
+}
+
+sub removefixedversions {
+ my $data = shift;
+ my $source = shift;
+ my $version = shift;
+ return unless defined $version;
+ undef $source if $source =~ m[(?:\s|/)];
+
+ foreach my $ver (split /[,\s]+/, $version) {
+ $ver = "$source/$ver" if defined $source;
+ @{$data->{fixed_versions}} =
+ grep { $_ ne $ver } @{$data->{fixed_versions}};
+ }
}
sub quit {
$out;
}
-sub bughook {
- my ( $type, $ref ) = ( shift, shift );
- &filelock("debbugs.trace.lock");
- &appendfile("debbugs.trace","$type $ref\n",@_);
- my @stuff=split/\n/, "$_[0]\n\n\n\n\n\n\n";
- # XXX: bug: this'll only keep the most recent update until index.db
- # starts getting overwritten by index.db.realtime after update
- my $hash = get_hashname($ref);
- unlink("$gSpoolDir/db/$ref.status.new");
- link("$gSpoolDir/db-h/$hash/$ref.status", "$gSpoolDir/db/$ref.status.new");
- rename("$gSpoolDir/db/$ref.status.new", "$gSpoolDir/db/$ref.status");
- open(IDXDB, "</org/bugs.debian.org/spool/index.db.realtime")
- or open(IDXDB, "</org/bugs.debian.org/spool/index.db");
- open(IDXNEW, ">/org/bugs.debian.org/spool/index.db.realtime.new");
- while(my $line = <IDXDB>) {
+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] == $ref);
+ last if ($line[1] >= $bug);
print IDXNEW $line;
+ $line = "";
}
- my $firstpkg;
- my $whendone = "open";
- my $severity = $gDefaultSeverity;
- ($firstpkg = $stuff[4]) =~ s/[,\s].*$//;
- $whendone = "forwarded" if length $stuff[7];
- $whendone = "done" if length $stuff[6];
- $severity = $stuff[9] if length $stuff[9];
-
- printf IDXNEW "%s %d %d %s [%s] %s %s\n",
- $firstpkg, $ref, $stuff[1], $whendone, $stuff[0],
- $severity, $stuff[5];
+
+ 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("/org/bugs.debian.org/spool/index.db.realtime.new",
- "/org/bugs.debian.org/spool/index.db.realtime");
+
+ 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 getmailbody {
my $entity = shift;
my $type = $entity->effective_type;
- if ($type eq 'text/plain' or
- ($type =~ m#text/# and $type ne 'text/html') or
+ if ($type =~ m#text/(?!html|enriched)# or
$type eq 'application/pgp') {
return $entity->bodyhandle;
} elsif ($type eq 'multipart/alternative') {
return undef;
}
+sub get_addresses {
+ return
+ map { $_->address() }
+ map { Mail::Address->parse($_) } @_;
+}
+
sub escapelog {
my @log = @_;
map { s/^([\01-\07\030])/\030$1/gm } @log;
return \@log;
}
+sub isstrongseverity {
+ my $severity = shift;
+ $severity = $gDefaultSeverity if $severity eq '';
+ return grep { $_ eq $severity } @gStrongSeverities;
+}
+
-@severities= @gSeverityList;
+@severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
@showseverities= @severities;
grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
-@strongseverities= @gStrongSeverities;
%displayshowseverities= %gSeverityDisplay;
+# compatibility
+if (defined $gFowardList and not defined $gForwardList) {
+ $gForwardList = $gFowardList;
+}
+
1;
projects / debbugs.git / blobdiff