scripts/errorlib.in

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