scripts/errorlib.in

   1 # -*- perl -*-
   2 # $Id: errorlib.in,v 1.52 2005/10/06 03:46:13 ajt Exp $
   3
   4 use Mail::Address;
   5 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
   6 use Debbugs::Packages;
   7
   8 sub F_SETLK { 6; } sub F_WRLCK{ 1; }
   9 $flockstruct= 'sslll'; # And there ought to be something for this too.
  10
  11 sub get_hashname {
  12     return "" if ( $_[ 0 ] < 0 );
  13     return sprintf "%02d", $_[ 0 ] % 100;
  14 }
  15
  16 sub unlockreadbugmerge {
  17     local ($rv) = @_;
  18     &unfilelock if $rv >= 2;
  19     &unfilelock if $rv >= 1;
  20 }
  21
  22 sub lockreadbugmerge {
  23     local ($lref, $location) = @_;
  24     local $data;
  25     if (!($data = &lockreadbug($lref, $location))) { return ( 0, undef ); }
  26     if (!length($data->{mergedwith})) { return ( 1, $data ); }
  27     &unfilelock;
  28     &filelock('lock/merge');
  29     if (!&lockreadbug($lref, $location)) { &unfilelock; return ( 0, undef ); }
  30     return ( 2, $data );
  31 }
  32
  33 sub getbuglocation {
  34     my ( $bugnum, $ext ) = @_;
  35     my $archdir = sprintf "%02d", $bugnum % 100;
  36     return 'archive' if ( -r "$gSpoolDir/archive/$archdir/$bugnum.$ext" );
  37     return 'db-h' if ( -r "$gSpoolDir/db-h/$archdir/$bugnum.$ext" );
  38     return 'db' if ( -r "$gSpoolDir/db/$bugnum.$ext" );
  39     return undef;
  40 }
  41
  42 sub getlocationpath {
  43     my ($location) = @_;
  44     if ($location eq 'archive') {
  45         return "$gSpoolDir/archive";
  46     } elsif ($location eq 'db') {
  47         return "$gSpoolDir/db";
  48     } else {
  49         return "$gSpoolDir/db-h";
  50     }
  51 }
  52
  53 sub getbugcomponent {
  54     my ($bugnum, $ext, $location) = @_;
  55
  56     unless (defined $location) {
  57         $location = getbuglocation($bugnum, $ext);
  58         # Default to non-archived bugs only for now; CGI scripts want
  59         # archived bugs but most of the backend scripts don't. For now,
  60         # anything that is prepared to accept archived bugs should call
  61         # getbuglocation() directly first.
  62         return undef if defined $location and
  63                         ($location ne 'db' and $location ne 'db-h');
  64     }
  65     my $dir = getlocationpath($location);
  66     return undef unless $dir;
  67     if ($location eq 'db') {
  68         return "$dir/$bugnum.$ext";
  69     } else {
  70         my $hash = get_hashname($bugnum);
  71         return "$dir/$hash/$bugnum.$ext";
  72     }
  73 }
  74
  75 my @v1fieldorder = qw(originator date subject msgid package
  76                       keywords done forwarded mergedwith severity);
  77
  78 my %fields = (originator => 'submitter',
  79               date => 'date',
  80               subject => 'subject',
  81               msgid => 'message-id',
  82               'package' => 'package',
  83               keywords => 'tags',
  84               done => 'done',
  85               forwarded => 'forwarded-to',
  86               mergedwith => 'merged-with',
  87               severity => 'severity',
  88               owner => 'owner',
  89               found_versions => 'found-in',
  90               fixed_versions => 'fixed-in',
  91               blocks => 'blocks',
  92               blockedby => 'blocked-by',
  93              );
  94
  95 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
  96 my @rfc1522_fields = qw(originator subject done forwarded owner);
  97
  98 sub readbug {
  99     my ($lref, $location) = @_;
 100     my $status = getbugcomponent($lref, 'summary', $location);
 101     return undef unless defined $status;
 102     if (!open(S,$status)) { return undef; }
 103
 104     my %data;
 105     my @lines;
 106     my $version = 2;
 107     local $_;
 108
 109     while (<S>) {
 110         chomp;
 111         push @lines, $_;
 112         $version = $1 if /^Format-Version: ([0-9]+)/i;
 113     }
 114
 115     # Version 3 is the latest format version currently supported.
 116     return undef if $version > 3;
 117
 118     my %namemap = reverse %fields;
 119     for my $line (@lines) {
 120         if ($line =~ /(\S+?): (.*)/) {
 121             my ($name, $value) = (lc $1, $2);
 122             $data{$namemap{$name}} = $value if exists $namemap{$name};
 123         }
 124     }
 125     for my $field (keys %fields) {
 126         $data{$field} = '' unless exists $data{$field};
 127     }
 128
 129     close(S);
 130
 131     $data{severity} = $gDefaultSeverity if $data{severity} eq '';
 132     $data{found_versions} = [split ' ', $data{found_versions}];
 133     $data{fixed_versions} = [split ' ', $data{fixed_versions}];
 134
 135     if ($version < 3) {
 136         for my $field (@rfc1522_fields) {
 137             $data{$field} = decode_rfc1522($data{$field});
 138         }
 139     }
 140
 141     return \%data;
 142 }
 143
 144 sub lockreadbug {
 145     local ($lref, $location) = @_;
 146     &filelock("lock/$lref");
 147     my $data = readbug($lref, $location);
 148     &unfilelock unless defined $data;
 149     return $data;
 150 }
 151
 152 sub makestatus {
 153     my $data = shift;
 154     my $version = shift;
 155     $version = 2 unless defined $version;
 156
 157     local $data->{found_versions} = join ' ', @{$data->{found_versions}};
 158     local $data->{fixed_versions} = join ' ', @{$data->{fixed_versions}};
 159
 160     my $contents = '';
 161
 162     my %newdata = %$data;
 163     if ($version < 3) {
 164         for my $field (@rfc1522_fields) {
 165             $newdata{$field} = encode_rfc1522($newdata{$field});
 166         }
 167     }
 168
 169     if ($version == 1) {
 170         for my $field (@v1fieldorder) {
 171             if (exists $newdata{$field}) {
 172                 $contents .= "$newdata{$field}\n";
 173             } else {
 174                 $contents .= "\n";
 175             }
 176         }
 177     } elsif ($version == 2 or $version == 3) {
 178         # Version 2 or 3. Add a file format version number for the sake of
 179         # further extensibility in the future.
 180         $contents .= "Format-Version: $version\n";
 181         for my $field (keys %fields) {
 182             if (exists $newdata{$field} and $newdata{$field} ne '') {
 183                 # Output field names in proper case, e.g. 'Merged-With'.
 184                 my $properfield = $fields{$field};
 185                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 186                 $contents .= "$properfield: $newdata{$field}\n";
 187             }
 188         }
 189     }
 190
 191     return $contents;
 192 }
 193
 194 sub writebug {
 195     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 196     my $change;
 197
 198     my %outputs = (1 => 'status', 2 => 'summary');
 199     for my $version (keys %outputs) {
 200         next if defined $minversion and $version < $minversion;
 201         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 202         &quit("can't find location for $ref") unless defined $status;
 203         open(S,"> $status.new") || &quit("opening $status.new: $!");
 204         print(S makestatus($data, $version)) ||
 205             &quit("writing $status.new: $!");
 206         close(S) || &quit("closing $status.new: $!");
 207         if (-e $status) {
 208             $change = 'change';
 209         } else {
 210             $change = 'new';
 211         }
 212         rename("$status.new",$status) || &quit("installing new $status: $!");
 213     }
 214
 215     # $disablebughook is a bit of a hack to let format migration scripts use
 216     # this function rather than having to duplicate it themselves.
 217     &bughook($change,$ref,$data) unless $disablebughook;
 218 }
 219
 220 sub unlockwritebug {
 221     writebug(@_);
 222     &unfilelock;
 223 }
 224
 225 sub filelock {
 226     # NB - NOT COMPATIBLE WITH `with-lock'
 227     local ($lockfile,$flockpushno,$evalstring,$count,$errors,@s1,@s2) = @_;
 228     $flockpushno= $#filelocks+1;
 229     $count= 10; $errors= '';
 230     for (;;) {
 231         $evalstring= "
 232             open(FLOCK${flockpushno},\"> \$lockfile\") || die \"open: \$!\";
 233             \$flockwant= pack(\$flockstruct,&F_WRLCK,0,0,1,0);".
 234                 ($] >= 5.000 ? "
 235             fcntl(FLOCK$flockpushno,&F_SETLK,\$flockwant) || die \"setlk: \$!\";" : "
 236             \$z= syscall(&SYS_fcntl,fileno(FLOCK$flockpushno),&F_SETLK,\$flockwant) < 0
 237                  && die \"syscall fcntl setlk: \$!\";") ."
 238             (\@s1= lstat(\$lockfile)) || die \"lstat: \$!\";
 239             (\@s2= stat(FLOCK$flockpushno)) || die \"fstat: \$!\";
 240             join(',',\@s1) eq join(',',\@s2) || die \"file switched\";
 241             1;
 242         ";
 243         last if eval $evalstring;
 244         $errors .= $@;
 245         eval "close(FLOCK$flockpushno);";
 246         if (--$count <=0) {
 247             $errors =~ s/\n+$//;
 248             &quit("failed to get lock on file $lockfile: $errors // $evalstring");
 249         }
 250         sleep 10;
 251     }
 252     push(@cleanups,'unfilelock');
 253     push(@filelocks,$lockfile);
 254 }
 255
 256 sub unfilelock {
 257     if (@filelocks == 0) {
 258         warn "unfilelock called with no active filelocks!\n";
 259         return;
 260     }
 261     local ($lockfile) = pop(@filelocks);
 262     pop(@cleanups);
 263     eval 'close(FLOCK'.($#filelocks+1).');' || warn "failed to close lock file $lockfile: $!";
 264     unlink($lockfile) || warn "failed to remove lock file $lockfile: $!";
 265 }
 266
 267 sub addfoundversions {
 268     my $data = shift;
 269     my $package = shift;
 270     my $version = shift;
 271     my $isbinary = shift;
 272     return unless defined $version;
 273     undef $package if $package =~ m[(?:\s|/)];
 274     my $source = $package;
 275
 276     if (defined $package and $isbinary) {
 277         my @srcinfo = binarytosource($package, $version, undef);
 278         if (@srcinfo) {
 279             # We know the source package(s). Use a fully-qualified version.
 280             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 281             return;
 282         }
 283         # Otherwise, an unqualified version will have to do.
 284     }
 285
 286     # Strip off various kinds of brain-damage.
 287     $version =~ s/;.*//;
 288     $version =~ s/ *\(.*\)//;
 289     $version =~ s/ +[A-Za-z].*//;
 290
 291     foreach my $ver (split /[,\s]+/, $version) {
 292         my $sver = defined($source) ? "$source/$ver" : '';
 293         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 294             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 295         }
 296         @{$data->{fixed_versions}} =
 297             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 298     }
 299 }
 300
 301 sub removefoundversions {
 302     my $data = shift;
 303     my $package = shift;
 304     my $version = shift;
 305     my $isbinary = shift;
 306     return unless defined $version;
 307     undef $package if $package =~ m[(?:\s|/)];
 308     my $source = $package;
 309
 310     if (defined $package and $isbinary) {
 311         my @srcinfo = binarytosource($package, $version, undef);
 312         if (@srcinfo) {
 313             # We know the source package(s). Use a fully-qualified version.
 314             removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 315             return;
 316         }
 317         # Otherwise, an unqualified version will have to do.
 318     }
 319
 320     foreach my $ver (split /[,\s]+/, $version) {
 321         my $sver = defined($source) ? "$source/$ver" : '';
 322         @{$data->{found_versions}} =
 323             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 324     }
 325 }
 326
 327 sub addfixedversions {
 328     my $data = shift;
 329     my $package = shift;
 330     my $version = shift;
 331     my $isbinary = shift;
 332     return unless defined $version;
 333     undef $package if $package =~ m[(?:\s|/)];
 334     my $source = $package;
 335
 336     if (defined $package and $isbinary) {
 337         my @srcinfo = binarytosource($package, $version, undef);
 338         if (@srcinfo) {
 339             # We know the source package(s). Use a fully-qualified version.
 340             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 341             return;
 342         }
 343         # Otherwise, an unqualified version will have to do.
 344     }
 345
 346     # Strip off various kinds of brain-damage.
 347     $version =~ s/;.*//;
 348     $version =~ s/ *\(.*\)//;
 349     $version =~ s/ +[A-Za-z].*//;
 350
 351     foreach my $ver (split /[,\s]+/, $version) {
 352         my $sver = defined($source) ? "$source/$ver" : '';
 353         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 354             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 355         }
 356         @{$data->{found_versions}} =
 357             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 358     }
 359 }
 360
 361 sub removefixedversions {
 362     my $data = shift;
 363     my $package = shift;
 364     my $version = shift;
 365     my $isbinary = shift;
 366     return unless defined $version;
 367     undef $package if $package =~ m[(?:\s|/)];
 368     my $source = $package;
 369
 370     if (defined $package and $isbinary) {
 371         my @srcinfo = binarytosource($package, $version, undef);
 372         if (@srcinfo) {
 373             # We know the source package(s). Use a fully-qualified version.
 374             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 375             return;
 376         }
 377         # Otherwise, an unqualified version will have to do.
 378     }
 379
 380     foreach my $ver (split /[,\s]+/, $version) {
 381         my $sver = defined($source) ? "$source/$ver" : '';
 382         @{$data->{fixed_versions}} =
 383             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 384     }
 385 }
 386
 387 sub quit {
 388     print DEBUG "quitting >$_[0]<\n";
 389     local ($u);
 390     while ($u= $cleanups[$#cleanups]) { &$u; }
 391     die "*** $_[0]\n";
 392 }
 393
 394 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
 395
 396 sub sani {
 397     local ($in) = @_;
 398     local ($out);
 399     while ($in =~ m/[<>&"]/) {
 400         $out.= $`. '&'. $saniarray{$&}. ';';
 401         $in=$';
 402     }
 403     $out.= $in;
 404     $out;
 405 }
 406
 407 sub update_realtime {
 408         my ($file, $bug, $new) = @_;
 409
 410         # update realtime index.db
 411
 412         open(IDXDB, "<$file") or die "Couldn't open $file";
 413         open(IDXNEW, ">$file.new");
 414
 415         my $line;
 416         my @line;
 417         while($line = <IDXDB>) {
 418                 @line = split /\s/, $line;
 419                 last if ($line[1] >= $bug);
 420                 print IDXNEW $line;
 421                 $line = "";
 422         }
 423
 424         if ($new eq "NOCHANGE") {
 425                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 426         } elsif ($new eq "REMOVE") {
 427                 0;
 428         } else {
 429                 print IDXNEW $new;
 430         }
 431         if ($line ne "" && $line[1] > $bug) {
 432                 print IDXNEW $line;
 433                 $line = "";
 434         }
 435
 436         print IDXNEW while(<IDXDB>);
 437
 438         close(IDXNEW);
 439         close(IDXDB);
 440
 441         rename("$file.new", $file);
 442
 443         return $line;
 444 }
 445
 446 sub bughook_archive {
 447         my $ref = shift;
 448         &filelock("debbugs.trace.lock");
 449         &appendfile("debbugs.trace","archive $ref\n");
 450         my $line = update_realtime(
 451                 "$gSpoolDir/index.db.realtime",
 452                 $ref,
 453                 "REMOVE");
 454         update_realtime("$gSpoolDir/index.archive.realtime",
 455                 $ref, $line);
 456         &unfilelock;
 457 }
 458
 459 sub bughook {
 460         my ( $type, $ref, $data ) = @_;
 461         &filelock("debbugs.trace.lock");
 462
 463         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 464
 465         my $whendone = "open";
 466         my $severity = $gDefaultSeverity;
 467         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 468         $pkglist =~ s/^,+//;
 469         $pkglist =~ s/,+$//;
 470         $whendone = "forwarded" if length $data->{forwarded};
 471         $whendone = "done" if length $data->{done};
 472         $severity = $data->{severity} if length $data->{severity};
 473
 474         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 475                         $pkglist, $ref, $data->{date}, $whendone,
 476                         $data->{originator}, $severity, $data->{keywords};
 477
 478         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 479
 480         &unfilelock;
 481 }
 482
 483 sub appendfile {
 484         my $file = shift;
 485         if (!open(AP,">>$file")) {
 486                 print DEBUG "failed open log<\n";
 487                 print DEBUG "failed open log err $!<\n";
 488                 &quit("opening $file (appendfile): $!");
 489         }
 490         print(AP @_) || &quit("writing $file (appendfile): $!");
 491         close(AP) || &quit("closing $file (appendfile): $!");
 492 }
 493
 494 sub getmailbody {
 495         my $entity = shift;
 496         my $type = $entity->effective_type;
 497         if ($type =~ m#text/(?!html|enriched)# or
 498             $type eq 'application/pgp') {
 499                 return $entity->bodyhandle;
 500         } elsif ($type eq 'multipart/alternative') {
 501                 # RFC 2046 says we should use the last part we recognize.
 502                 for my $part (reverse $entity->parts) {
 503                         my $ret = getmailbody($part);
 504                         return $ret if $ret;
 505                 }
 506         } else {
 507                 # For other multipart types, we just pretend they're
 508                 # multipart/mixed and run through in order.
 509                 for my $part ($entity->parts) {
 510                         my $ret = getmailbody($part);
 511                         return $ret if $ret;
 512                 }
 513         }
 514         return undef;
 515 }
 516
 517 sub get_addresses {
 518         return
 519             map { $_->address() }
 520             map { Mail::Address->parse($_) } @_;
 521 }
 522
 523 sub escapelog {
 524         my @log = @_;
 525         map { s/^([\01-\07\030])/\030$1/gm } @log;
 526         return \@log;
 527 }
 528
 529 sub isstrongseverity {
 530     my $severity = shift;
 531     $severity = $gDefaultSeverity if $severity eq '';
 532     return grep { $_ eq $severity } @gStrongSeverities;
 533 }
 534
 535
 536 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 537 @showseverities= @severities;
 538 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 539 %displayshowseverities= %gSeverityDisplay;
 540
 541 # compatibility
 542 if (defined $gFowardList and not defined $gForwardList) {
 543     $gForwardList = $gFowardList;
 544 }
 545
 546 1;