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