# -*- perl -*-
-# $Id: errorlib.in,v 1.40 2003/08/30 00:15:15 cjwatson Exp $
use Mail::Address;
-
-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::MIME qw(decode_rfc1522 encode_rfc1522);
+use Debbugs::Packages qw(:all);
+use Debbugs::Common qw(:all);
+use Debbugs::Status qw(:all);
+use Carp;
sub unlockreadbugmerge {
local ($rv) = @_;
local ($lref, $location) = @_;
local $data;
if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
- if (!length($data{mergedwith})) { return ( 1, $data ); }
+ if (!length($data->{mergedwith})) { return ( 1, $data ); }
&unfilelock;
&filelock('lock/merge');
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',
- );
-
-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 2 is the latest format version currently supported.
- return undef if $version > 2;
-
- 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} = 'normal' if $data{severity} eq '';
-
- 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;
-
- my $contents = '';
-
- if ($version == 1) {
- for my $field (@v1fieldorder) {
- if (exists $data->{$field}) {
- $contents .= "$data->{$field}\n";
- } else {
- $contents .= "\n";
- }
- }
- } elsif ($version == 2) {
- # Version 2. Add a file format version number for the sake of
- # further extensibility in the future.
- $contents .= "Format-Version: 2\n";
- for my $field (keys %fields) {
- if (exists $data->{$field} and $data->{$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: $data->{$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 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 {
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 \@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);