scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.30 2003/06/10 00:59:36 cjwatson Exp $
   3
   4 sub F_SETLK { 6; } sub F_WRLCK{ 1; }
   5 $flockstruct= 'sslll'; # And there ought to be something for this too.
   6
   7 sub get_hashname {
   8     return "" if ( $_[ 0 ] < 0 );
   9     return sprintf "%02d", $_[ 0 ] % 100;
  10 }
  11
  12 sub unlockreadbugmerge {
  13     local ($rv) = @_;
  14     &unfilelock if $rv >= 2;
  15     &unfilelock if $rv >= 1;
  16 }
  17
  18 sub lockreadbugmerge {
  19     local ($lref, $location) = @_;
  20     local $data;
  21     if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
  22     if (!length($data{mergedwith})) { return ( 1, $data ); }
  23     &unfilelock;
  24     &filelock('lock/merge');
  25     if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
  26     return ( 2, $data );
  27 }
  28
  29 sub getbuglocation {
  30     my ( $bugnum, $ext ) = @_;
  31     my $archdir = sprintf "%02d", $bugnum % 100;
  32     return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
  33     return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
  34     return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
  35     return undef;
  36 }
  37
  38 sub getlocationpath {
  39     my ($location) = @_;
  40     if ($location eq 'archive') {
  41         return "$gSpoolDir/archive";
  42     } elsif ($location eq 'db') {
  43         return "$gSpoolDir/db";
  44     } else {
  45         return "$gSpoolDir/db-h";
  46     }
  47 }
  48
  49 sub getbugcomponent {
  50     my ($bugnum, $ext, $location) = @_;
  51
  52     unless (defined $location) {
  53         $location = getbuglocation($bugnum, $ext);
  54         # Default to non-archived bugs only for now; CGI scripts want
  55         # archived bugs but most of the backend scripts don't. For now,
  56         # anything that is prepared to accept archived bugs should call
  57         # getbuglocation() directly first.
  58         return undef unless $location eq 'db' or $location eq 'db-h';
  59     }
  60     my $dir = getlocationpath($location);
  61     return undef unless $dir;
  62     if ($location eq 'db') {
  63         return "$dir/$bugnum.$ext";
  64     } else {
  65         my $hash = get_hashname($bugnum);
  66         return "$dir/$hash/$bugnum.$ext";
  67     }
  68 }
  69
  70 sub readbug {
  71     local ($lref, $location) = @_;
  72     my $status = getbugcomponent($lref, 'status', $location);
  73     return undef unless defined $status;
  74     if (!open(S,$status)) { return undef; }
  75     my %data;
  76     chop($data{originator}= <S>);
  77     chop($data{date}= <S>);
  78     chop($data{subject}= <S>);
  79     chop($data{msgid}= <S>);
  80     chop($data{package}= <S>);
  81     chop($data{keywords}= <S>);
  82     chop($data{done}= <S>);
  83     chop($data{forwarded}= <S>);
  84     chop($data{mergedwith}= <S>);
  85     chop($data{severity}= <S>);
  86     chop($data{versions}= <S>);
  87     chop($data{fixed_versions}= <S>);
  88     close(S);
  89         $data{severity} = 'normal' if $data{severity} eq '';
  90     return \%data;
  91 }
  92
  93 sub lockreadbug {
  94     local ($lref, $location) = @_;
  95     &filelock("lock/$lref");
  96     my $data = readbug($lref, $location);
  97     &unfilelock unless defined $data;
  98     return $data;
  99 }
 100
 101 sub writebug {
 102     local ($ref, $data, $location) = @_;
 103     my $change;
 104     my $status = getbugcomponent($ref, 'status', $location);
 105     &quit("can't find location for $ref") unless defined $status;
 106     open(S,"> $status.new") || &quit("opening $status.new: $!");
 107     print(S
 108           "$data->{originator}\n".
 109           "$data->{date}\n".
 110           "$data->{subject}\n".
 111           "$data->{msgid}\n".
 112           "$data->{package}\n".
 113           "$data->{keywords}\n".
 114           "$data->{done}\n".
 115           "$data->{forwarded}\n".
 116           "$data->{mergedwith}\n".
 117           "$data->{severity}\n".
 118           "$data->{versions}\n".
 119           "$data->{fixed_versions}\n") || &quit("writing $status.new: $!");
 120     close(S) || &quit("closing $status.new: $!");
 121     if (-e $status) {
 122         $change = 'change';
 123     } else {
 124         $change = 'new';
 125     }
 126     rename("$status.new",$status) ||
 127         &quit("installing new $status: $!");
 128         &bughook($change,$ref,
 129           "$data->{originator}\n".
 130           "$data->{date}\n".
 131           "$data->{subject}\n".
 132           "$data->{msgid}\n".
 133           "$data->{package}\n".
 134           "$data->{keywords}\n".
 135           "$data->{done}\n".
 136           "$data->{forwarded}\n".
 137           "$data->{mergedwith}\n".
 138           "$data->{severity}\n".
 139           "$data->{versions}\n".
 140           "$data->{fixed_versions}\n");
 141 }
 142
 143 sub unlockwritebug {
 144     writebug(@_);
 145     &unfilelock;
 146 }
 147
 148 sub filelock {
 149     # NB - NOT COMPATIBLE WITH `with-lock'
 150     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
 151     $flockpushno= $#filelocks+1;
 152     $count= 10; $errors= '';
 153     for (;;) {
 154         $evalstring= "
 155             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
 156             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
 157                 ($] >= 5.000 ? "
 158             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
 159             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
 160                  && die \"syscall fcntl setlk: \$!\";") ."
 161             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
 162             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
 163             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
 164             1;
 165         ";
 166         last if eval $evalstring;
 167         $errors .= $@;
 168         eval "close(FLOCK$flockpushno);";
 169         if (--$count <=0) {
 170             $errors =~ s/\n+$//;
 171             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
 172         }
 173         sleep 10;
 174     }
 175     push(@cleanups,'unfilelock');
 176     push(@filelocks,$lockfile);
 177 }
 178
 179 sub unfilelock {
 180     if (@filelocks == 0) {
 181         warn "unfilelock called with no active filelocks!\n";
 182         return;
 183     }
 184     local ($lockfile) = pop(@filelocks);
 185     pop(@cleanups);
 186     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
 187     unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
 188 }
 189
 190 sub quit {
 191     print DEBUG "quitting >$_[0]<\n";
 192     local ($u);
 193     while ($u= $cleanups[$#cleanups]) { &$u; }
 194     die "*** $_[0]\n";
 195 }
 196
 197 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
 198
 199 sub sani {
 200     local ($in) = @_;
 201     local ($out);
 202     while ($in =~ m/[<>&"]/) {
 203         $out.= $`. '&'. $saniarray{$&}. ';';
 204         $in=$';
 205     }
 206     $out.= $in;
 207     $out;
 208 }
 209
 210 sub update_realtime {
 211         my ($file, $bug, $new) = @_;
 212
 213         # update realtime index.db
 214
 215         open(IDXDB, "<$file") or die "Couldn't open $file";
 216         open(IDXNEW, ">$file.new");
 217
 218         my $line;
 219         my @line;
 220         while($line = <IDXDB>) {
 221                 @line = split /\s/, $line;
 222                 last if ($line[1] >= $bug);
 223                 print IDXNEW $line;
 224                 $line = "";
 225         }
 226
 227         if ($new eq "NOCHANGE") {
 228                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 229         } elsif ($new eq "REMOVE") {
 230                 0;
 231         } else {
 232                 print IDXNEW $new;
 233         }
 234         if ($line ne "" && $line[1] > $bug) {
 235                 print IDXNEW $line;
 236                 $line = "";
 237         }
 238
 239         print IDXNEW while(<IDXDB>);
 240
 241         close(IDXNEW);
 242         close(IDXDB);
 243
 244         rename("$file.new", $file);
 245
 246         return $line;
 247 }
 248
 249 sub bughook_archive {
 250         my $ref = shift;
 251         &filelock("debbugs.trace.lock");
 252         &appendfile("debbugs.trace","archive $ref\n");
 253         my $line = update_realtime(
 254                 "$gSpoolDir/index.db.realtime",
 255                 $ref,
 256                 "REMOVE");
 257         update_realtime("$gSpoolDir/index.archive.realtime",
 258                 $ref, $line);
 259         &unfilelock;
 260 }
 261
 262 sub bughook {
 263         my ( $type, $ref ) = ( shift, shift );
 264         &filelock("debbugs.trace.lock");
 265
 266         &appendfile("debbugs.trace","$type $ref\n",@_);
 267
 268         my @stuff=split /\n/, "$_[0]\n\n\n\n\n\n\n";
 269
 270         my $whendone = "open";
 271         my $severity = $gDefaultSeverity;
 272         (my $pkglist = $stuff[4]) =~ s/[,\s]+/,/g;
 273         $pkglist =~ s/^,+//;
 274         $pkglist =~ s/,+$//;
 275         $whendone = "forwarded" if length $stuff[7];
 276         $whendone = "done" if length $stuff[6];
 277         $severity = $stuff[9] if length $stuff[9];
 278
 279         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 280                         $pkglist, $ref, $stuff[1], $whendone, $stuff[0],
 281                         $severity, $stuff[5];
 282
 283         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 284
 285         &unfilelock;
 286 }
 287
 288 sub appendfile {
 289         my $file = shift;
 290         if (!open(AP,">>$file")) {
 291                 print DEBUG "failed open log<\n";
 292                 print DEBUG "failed open log err $!<\n";
 293                 &quit("opening $file (appendfile): $!");
 294         }
 295         print(AP @_) || &quit("writing $file (appendfile): $!");
 296         close(AP) || &quit("closing $file (appendfile): $!");
 297 }
 298
 299 sub getmailbody {
 300         my $entity = shift;
 301         my $type = $entity->effective_type;
 302         if ($type eq 'text/plain' or
 303             ($type =~ m#text/# and $type ne 'text/html') or
 304             $type eq 'application/pgp') {
 305                 return $entity->bodyhandle;
 306         } elsif ($type eq 'multipart/alternative') {
 307                 # RFC 2046 says we should use the last part we recognize.
 308                 for my $part (reverse $entity->parts) {
 309                         my $ret = getmailbody($part);
 310                         return $ret if $ret;
 311                 }
 312         } else {
 313                 # For other multipart types, we just pretend they're
 314                 # multipart/mixed and run through in order.
 315                 for my $part ($entity->parts) {
 316                         my $ret = getmailbody($part);
 317                         return $ret if $ret;
 318                 }
 319         }
 320         return undef;
 321 }
 322
 323 sub escapelog {
 324         my @log = @_;
 325         map { s/^([\01-\07\030])/\030$1/gm } @log;
 326         return \@log;
 327 }
 328
 329
 330 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 331 @showseverities= @severities;
 332 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 333 @strongseverities= @gStrongSeverities;
 334 %displayshowseverities= %gSeverityDisplay;
 335
 336 1;