scripts/errorlib.in

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