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         undef $source;
 285     }
 286
 287     # Strip off various kinds of brain-damage.
 288     $version =~ s/;.*//;
 289     $version =~ s/ *\(.*\)//;
 290     $version =~ s/ +[A-Za-z].*//;
 291
 292     foreach my $ver (split /[,\s]+/, $version) {
 293         my $sver = defined($source) ? "$source/$ver" : '';
 294         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 295             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 296         }
 297         @{$data->{fixed_versions}} =
 298             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 299     }
 300 }
 301
 302 =head2 removefoundversions
 303
 304      removefoundversions($data,$package,$versiontoremove)
 305
 306 Removes found versions from $data
 307
 308 If a version is fully qualified (contains /) only versions matching
 309 exactly are removed. Otherwise, all versions matching the version
 310 number are removed.
 311
 312 Currently $package and $isbinary are entirely ignored, but accepted
 313 for backwards compatibilty.
 314
 315 =cut
 316
 317 sub removefoundversions {
 318     my $data = shift;
 319     my $package = shift;
 320     my $version = shift;
 321     my $isbinary = shift;
 322     return unless defined $version;
 323
 324     foreach my $ver (split /[,\s]+/, $version) {
 325          if ($ver =~ m{/}) {
 326               # fully qualified version
 327               @{$data->{found_versions}} =
 328                    grep {$_ ne $ver}
 329                         @{$data->{found_versions}};
 330          }
 331          else {
 332               # non qualified version; delete all matchers
 333               @{$data->{found_versions}} =
 334                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 335                         @{$data->{found_versions}};
 336          }
 337     }
 338 }
 339
 340 sub addfixedversions {
 341     my $data = shift;
 342     my $package = shift;
 343     my $version = shift;
 344     my $isbinary = shift;
 345     return unless defined $version;
 346     undef $package if $package =~ m[(?:\s|/)];
 347     my $source = $package;
 348
 349     if (defined $package and $isbinary) {
 350         my @srcinfo = binarytosource($package, $version, undef);
 351         if (@srcinfo) {
 352             # We know the source package(s). Use a fully-qualified version.
 353             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 354             return;
 355         }
 356         # Otherwise, an unqualified version will have to do.
 357         undef $source;
 358     }
 359
 360     # Strip off various kinds of brain-damage.
 361     $version =~ s/;.*//;
 362     $version =~ s/ *\(.*\)//;
 363     $version =~ s/ +[A-Za-z].*//;
 364
 365     foreach my $ver (split /[,\s]+/, $version) {
 366         my $sver = defined($source) ? "$source/$ver" : '';
 367         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 368             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 369         }
 370         @{$data->{found_versions}} =
 371             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 372     }
 373 }
 374
 375 sub removefixedversions {
 376     my $data = shift;
 377     my $package = shift;
 378     my $version = shift;
 379     my $isbinary = shift;
 380     return unless defined $version;
 381     undef $package if $package =~ m[(?:\s|/)];
 382     my $source = $package;
 383
 384     if (defined $package and $isbinary) {
 385         my @srcinfo = binarytosource($package, $version, undef);
 386         if (@srcinfo) {
 387             # We know the source package(s). Use a fully-qualified version.
 388             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 389             return;
 390         }
 391         # Otherwise, an unqualified version will have to do.
 392         undef $source;
 393     }
 394
 395     foreach my $ver (split /[,\s]+/, $version) {
 396         my $sver = defined($source) ? "$source/$ver" : '';
 397         @{$data->{fixed_versions}} =
 398             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 399     }
 400 }
 401
 402 sub quit {
 403     print DEBUG "quitting >$_[0]<\n";
 404     local ($u);
 405     while ($u= $cleanups[$#cleanups]) { &$u; }
 406     die "*** $_[0]\n";
 407 }
 408
 409 %saniarray= ('<','lt', '>','gt', '&','amp', '"','quot');
 410
 411 sub sani {
 412     local ($in) = @_;
 413     local ($out);
 414     while ($in =~ m/[<>&"]/) {
 415         $out.= $`. '&'. $saniarray{$&}. ';';
 416         $in=$';
 417     }
 418     $out.= $in;
 419     $out;
 420 }
 421
 422 sub update_realtime {
 423         my ($file, $bug, $new) = @_;
 424
 425         # update realtime index.db
 426
 427         open(IDXDB, "<$file") or die "Couldn't open $file";
 428         open(IDXNEW, ">$file.new");
 429
 430         my $line;
 431         my @line;
 432         while($line = <IDXDB>) {
 433                 @line = split /\s/, $line;
 434                 last if ($line[1] >= $bug);
 435                 print IDXNEW $line;
 436                 $line = "";
 437         }
 438
 439         if ($new eq "NOCHANGE") {
 440                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 441         } elsif ($new eq "REMOVE") {
 442                 0;
 443         } else {
 444                 print IDXNEW $new;
 445         }
 446         if ($line ne "" && $line[1] > $bug) {
 447                 print IDXNEW $line;
 448                 $line = "";
 449         }
 450
 451         print IDXNEW while(<IDXDB>);
 452
 453         close(IDXNEW);
 454         close(IDXDB);
 455
 456         rename("$file.new", $file);
 457
 458         return $line;
 459 }
 460
 461 sub bughook_archive {
 462         my $ref = shift;
 463         &filelock("debbugs.trace.lock");
 464         &appendfile("debbugs.trace","archive $ref\n");
 465         my $line = update_realtime(
 466                 "$gSpoolDir/index.db.realtime",
 467                 $ref,
 468                 "REMOVE");
 469         update_realtime("$gSpoolDir/index.archive.realtime",
 470                 $ref, $line);
 471         &unfilelock;
 472 }
 473
 474 sub bughook {
 475         my ( $type, $ref, $data ) = @_;
 476         &filelock("debbugs.trace.lock");
 477
 478         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 479
 480         my $whendone = "open";
 481         my $severity = $gDefaultSeverity;
 482         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 483         $pkglist =~ s/^,+//;
 484         $pkglist =~ s/,+$//;
 485         $whendone = "forwarded" if length $data->{forwarded};
 486         $whendone = "done" if length $data->{done};
 487         $severity = $data->{severity} if length $data->{severity};
 488
 489         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 490                         $pkglist, $ref, $data->{date}, $whendone,
 491                         $data->{originator}, $severity, $data->{keywords};
 492
 493         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 494
 495         &unfilelock;
 496 }
 497
 498 sub appendfile {
 499         my $file = shift;
 500         if (!open(AP,">>$file")) {
 501                 print DEBUG "failed open log<\n";
 502                 print DEBUG "failed open log err $!<\n";
 503                 &quit("opening $file (appendfile): $!");
 504         }
 505         print(AP @_) || &quit("writing $file (appendfile): $!");
 506         close(AP) || &quit("closing $file (appendfile): $!");
 507 }
 508
 509 sub getmailbody {
 510         my $entity = shift;
 511         my $type = $entity->effective_type;
 512         if ($type =~ m#text/(?!html|enriched)# or
 513             $type eq 'application/pgp') {
 514                 return $entity->bodyhandle;
 515         } elsif ($type eq 'multipart/alternative') {
 516                 # RFC 2046 says we should use the last part we recognize.
 517                 for my $part (reverse $entity->parts) {
 518                         my $ret = getmailbody($part);
 519                         return $ret if $ret;
 520                 }
 521         } else {
 522                 # For other multipart types, we just pretend they're
 523                 # multipart/mixed and run through in order.
 524                 for my $part ($entity->parts) {
 525                         my $ret = getmailbody($part);
 526                         return $ret if $ret;
 527                 }
 528         }
 529         return undef;
 530 }
 531
 532 sub get_addresses {
 533         return
 534             map { $_->address() }
 535             map { Mail::Address->parse($_) } @_;
 536 }
 537
 538 sub escapelog {
 539         my @log = @_;
 540         map { s/^([\01-\07\030])/\030$1/gm } @log;
 541         return \@log;
 542 }
 543
 544 sub isstrongseverity {
 545     my $severity = shift;
 546     $severity = $gDefaultSeverity if $severity eq '';
 547     return grep { $_ eq $severity } @gStrongSeverities;
 548 }
 549
 550
 551 @severities= grep { not exists $gObsoleteSeverities{$_} } @gSeverityList;
 552 @showseverities= @severities;
 553 grep ($_= $_ eq '' ? $gDefaultSeverity : $_, @showseverities);
 554 %displayshowseverities= %gSeverityDisplay;
 555
 556 # compatibility
 557 if (defined $gFowardList and not defined $gForwardList) {
 558     $gForwardList = $gFowardList;
 559 }
 560
 561 1;