scripts/errorlib.in

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