Debbugs/Status.pm

   1
   2 package Debbugs::Status;
   3
   4 =head1 NAME
   5
   6 Debbugs::Status -- Routines for dealing with summary and status files
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::Status;
  11
  12
  13 =head1 DESCRIPTION
  14
  15 This module is a replacement for the parts of errorlib.pl which write
  16 and read status and summary files.
  17
  18 It also contains generic routines for returning information about the
  19 status of a particular bug
  20
  21 =head1 FUNCTIONS
  22
  23 =cut
  24
  25 use warnings;
  26 use strict;
  27 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  28 use base qw(Exporter);
  29
  30 use Params::Validate qw(validate_with :types);
  31 use Debbugs::Common qw(:util :lock);
  32 use Debbugs::Config qw(:config);
  33
  34 BEGIN{
  35      $VERSION = 1.00;
  36      $DEBUG = 0 unless defined $DEBUG;
  37
  38      @EXPORT = ();
  39      %EXPORT_TAGS = (status => [qw(splitpackages getbugstatus)],
  40                      read   => [qw(readbug lockreadbug)],
  41                      write  => [qw(writebug makestatus unlockwritebug)],
  42                      versions => [qw(addfoundversion addfixedversion),
  43                                   qw(),
  44                                  ],
  45                     );
  46      @EXPORT_OK = ();
  47      Exporter::export_ok_tags(qw(splitpackages));
  48      $EXPORT_TAGS{all} = [@EXPORT_OK];
  49 }
  50
  51
  52 =head2 readbug
  53
  54      readbug($bug_number,$location)
  55
  56 Reads a summary file from the archive given a bug number and a bug
  57 location. Valid locations are those understood by L</getbugcomponent>
  58
  59 =cut
  60
  61
  62 my %fields = (originator     => 'submitter',
  63               date           => 'date',
  64               subject        => 'subject',
  65               msgid          => 'message-id',
  66               'package'      => 'package',
  67               keywords       => 'tags',
  68               done           => 'done',
  69               forwarded      => 'forwarded-to',
  70               mergedwith     => 'merged-with',
  71               severity       => 'severity',
  72               owner          => 'owner',
  73               found_versions => 'found-in',
  74               found_date     => 'found-date',
  75               fixed_versions => 'fixed-in',
  76               fixed_date     => 'fixed-date',
  77               blocks         => 'blocks',
  78               blockedby      => 'blocked-by',
  79              );
  80
  81 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
  82 my @rfc1522_fields = qw(originator subject done forwarded owner);
  83
  84 =head2 readbug
  85
  86      readbug($bug_num,$location);
  87      readbug($bug_num)
  88
  89
  90 Retreives the information from the summary files for a particular bug
  91 number. If location is not specified, getbuglocation is called to fill
  92 it in.
  93
  94 =cut
  95
  96 sub readbug {
  97     my ($lref, $location) = @_;
  98     if (not defined $location) {
  99          $location = getbuglocation($lref,'summary');
 100          return undef if not defined $location;
 101     }
 102     my $status = getbugcomponent($lref, 'summary', $location);
 103     return undef unless defined $status;
 104     my $status_fh = new IO::File $status, 'r' or
 105          warn "Unable to open $status for reading: $!" and return undef;
 106
 107     my %data;
 108     my @lines;
 109     my $version = 2;
 110     local $_;
 111
 112     while (<$status_fh>) {
 113         chomp;
 114         push @lines, $_;
 115         $version = $1 if /^Format-Version: ([0-9]+)/i;
 116     }
 117
 118     # Version 3 is the latest format version currently supported.
 119     return undef if $version > 3;
 120
 121     my %namemap = reverse %fields;
 122     for my $line (@lines) {
 123         if ($line =~ /(\S+?): (.*)/) {
 124             my ($name, $value) = (lc $1, $2);
 125             $data{$namemap{$name}} = $value if exists $namemap{$name};
 126         }
 127     }
 128     for my $field (keys %fields) {
 129         $data{$field} = '' unless exists $data{$field};
 130     }
 131
 132     $data{severity} = $config{default_severity} if $data{severity} eq '';
 133     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 134          $data{$field} = [split ' ', $data{$field}];
 135     }
 136     for my $field (qw(found fixed)) {
 137          $data{$field}{@{$data{${field}_versions}}} =
 138               ('') x (@{$data{${field}_date}} - @{$data{${field}_versions}}),
 139                    @{$data{${field}_date}};
 140     }
 141
 142     if ($version < 3) {
 143         for my $field (@rfc1522_fields) {
 144             $data{$field} = decode_rfc1522($data{$field});
 145         }
 146     }
 147
 148     return \%data;
 149 }
 150
 151 =head2 lockreadbug
 152
 153      lockreadbug($bug_num,$location)
 154
 155 Performs a filelock, then reads the bug; the bug is unlocked if the
 156 return is undefined, otherwise, you need to call unfilelock or
 157 unlockwritebug.
 158
 159 See readbug above for information on what this returns
 160
 161 =cut
 162
 163 sub lockreadbug {
 164     local ($lref, $location) = @_;
 165     &filelock("lock/$lref");
 166     my $data = readbug($lref, $location);
 167     &unfilelock unless defined $data;
 168     return $data;
 169 }
 170
 171 my @v1fieldorder = qw(originator date subject msgid package
 172                       keywords done forwarded mergedwith severity);
 173
 174 =head2 makestatus
 175
 176      my $content = makestatus($status,$version)
 177      my $content = makestatus($status);
 178
 179 Creates the content for a status file based on the $status hashref
 180 passed.
 181
 182 Really only useful for writebug
 183
 184 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 185 eventually default to version 3. If you care, you should specify a
 186 version.
 187
 188 =cut
 189
 190 sub makestatus {
 191     my ($data,$version) = @_;
 192     $version = 2 unless defined $version;
 193
 194     my $contents = '';
 195
 196     my %newdata = %$data;
 197     for my $field (qw(found fixed)) {
 198          if (exists $data{$field}) {
 199               $data{"${field}_date"} =
 200                    [map {$data{$field}{$_}||''} keys %{$data{$field}}];
 201          }
 202     }
 203
 204     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 205          $newdata{$field} = [split ' ', $newdata{$field}];
 206     }
 207
 208     if ($version < 3) {
 209         for my $field (@rfc1522_fields) {
 210             $newdata{$field} = encode_rfc1522($newdata{$field});
 211         }
 212     }
 213
 214     if ($version == 1) {
 215         for my $field (@v1fieldorder) {
 216             if (exists $newdata{$field}) {
 217                 $contents .= "$newdata{$field}\n";
 218             } else {
 219                 $contents .= "\n";
 220             }
 221         }
 222     } elsif ($version == 2 or $version == 3) {
 223         # Version 2 or 3. Add a file format version number for the sake of
 224         # further extensibility in the future.
 225         $contents .= "Format-Version: $version\n";
 226         for my $field (keys %fields) {
 227             if (exists $newdata{$field} and $newdata{$field} ne '') {
 228                 # Output field names in proper case, e.g. 'Merged-With'.
 229                 my $properfield = $fields{$field};
 230                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 231                 $contents .= "$properfield: $newdata{$field}\n";
 232             }
 233         }
 234     }
 235
 236     return $contents;
 237 }
 238
 239 =head2 writebug
 240
 241      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 242
 243 Writes the bug status and summary files out.
 244
 245 Skips writting out a status file if minversion is 2
 246
 247 Does not call bughook if disablebughook is true.
 248
 249 =cut
 250
 251 sub writebug {
 252     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 253     my $change;
 254
 255     my %outputs = (1 => 'status', 2 => 'summary');
 256     for my $version (keys %outputs) {
 257         next if defined $minversion and $version < $minversion;
 258         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 259         &quit("can't find location for $ref") unless defined $status;
 260         open(S,"> $status.new") || &quit("opening $status.new: $!");
 261         print(S makestatus($data, $version)) ||
 262             &quit("writing $status.new: $!");
 263         close(S) || &quit("closing $status.new: $!");
 264         if (-e $status) {
 265             $change = 'change';
 266         } else {
 267             $change = 'new';
 268         }
 269         rename("$status.new",$status) || &quit("installing new $status: $!");
 270     }
 271
 272     # $disablebughook is a bit of a hack to let format migration scripts use
 273     # this function rather than having to duplicate it themselves.
 274     &bughook($change,$ref,$data) unless $disablebughook;
 275 }
 276
 277 =head2 unlockwritebug
 278
 279      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 280
 281 Writes a bug, then calls unfilelock; see writebug for what these
 282 options mean.
 283
 284 =cut
 285
 286 sub unlockwritebug {
 287     writebug(@_);
 288     &unfilelock;
 289 }
 290
 291 =head1 VERSIONS
 292
 293 The following functions are exported with the :versions tag
 294
 295 =head2 addfoundversions
 296
 297      addfoundversions($status,$package,$version,$isbinary);
 298
 299
 300
 301 =cut
 302
 303
 304 sub addfoundversions {
 305     my $data = shift;
 306     my $package = shift;
 307     my $version = shift;
 308     my $isbinary = shift;
 309     return unless defined $version;
 310     undef $package if $package =~ m[(?:\s|/)];
 311     my $source = $package;
 312
 313     if (defined $package and $isbinary) {
 314         my @srcinfo = binarytosource($package, $version, undef);
 315         if (@srcinfo) {
 316             # We know the source package(s). Use a fully-qualified version.
 317             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 318             return;
 319         }
 320         # Otherwise, an unqualified version will have to do.
 321         undef $source;
 322     }
 323
 324     # Strip off various kinds of brain-damage.
 325     $version =~ s/;.*//;
 326     $version =~ s/ *\(.*\)//;
 327     $version =~ s/ +[A-Za-z].*//;
 328
 329     foreach my $ver (split /[,\s]+/, $version) {
 330         my $sver = defined($source) ? "$source/$ver" : '';
 331         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 332             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 333         }
 334         @{$data->{fixed_versions}} =
 335             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 336     }
 337 }
 338
 339 sub removefoundversions {
 340     my $data = shift;
 341     my $package = shift;
 342     my $version = shift;
 343     my $isbinary = shift;
 344     return unless defined $version;
 345     undef $package if $package =~ m[(?:\s|/)];
 346     my $source = $package;
 347
 348     if (defined $package and $isbinary) {
 349         my @srcinfo = binarytosource($package, $version, undef);
 350         if (@srcinfo) {
 351             # We know the source package(s). Use a fully-qualified version.
 352             removefoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 353             return;
 354         }
 355         # Otherwise, an unqualified version will have to do.
 356         undef $source;
 357     }
 358
 359     foreach my $ver (split /[,\s]+/, $version) {
 360         my $sver = defined($source) ? "$source/$ver" : '';
 361         @{$data->{found_versions}} =
 362             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 363     }
 364 }
 365
 366 sub addfixedversions {
 367     my $data = shift;
 368     my $package = shift;
 369     my $version = shift;
 370     my $isbinary = shift;
 371     return unless defined $version;
 372     undef $package if $package =~ m[(?:\s|/)];
 373     my $source = $package;
 374
 375     if (defined $package and $isbinary) {
 376         my @srcinfo = binarytosource($package, $version, undef);
 377         if (@srcinfo) {
 378             # We know the source package(s). Use a fully-qualified version.
 379             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 380             return;
 381         }
 382         # Otherwise, an unqualified version will have to do.
 383         undef $source;
 384     }
 385
 386     # Strip off various kinds of brain-damage.
 387     $version =~ s/;.*//;
 388     $version =~ s/ *\(.*\)//;
 389     $version =~ s/ +[A-Za-z].*//;
 390
 391     foreach my $ver (split /[,\s]+/, $version) {
 392         my $sver = defined($source) ? "$source/$ver" : '';
 393         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 394             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 395         }
 396         @{$data->{found_versions}} =
 397             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 398     }
 399 }
 400
 401 sub removefixedversions {
 402     my $data = shift;
 403     my $package = shift;
 404     my $version = shift;
 405     my $isbinary = shift;
 406     return unless defined $version;
 407     undef $package if $package =~ m[(?:\s|/)];
 408     my $source = $package;
 409
 410     if (defined $package and $isbinary) {
 411         my @srcinfo = binarytosource($package, $version, undef);
 412         if (@srcinfo) {
 413             # We know the source package(s). Use a fully-qualified version.
 414             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 415             return;
 416         }
 417         # Otherwise, an unqualified version will have to do.
 418         undef $source;
 419     }
 420
 421     foreach my $ver (split /[,\s]+/, $version) {
 422         my $sver = defined($source) ? "$source/$ver" : '';
 423         @{$data->{fixed_versions}} =
 424             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 425     }
 426 }
 427
 428
 429
 430 =head2 splitpackages
 431
 432      splitpackages($pkgs)
 433
 434 Split a package string from the status file into a list of package names.
 435
 436 =cut
 437
 438 sub splitpackages {
 439     my $pkgs = shift;
 440     return unless defined $pkgs;
 441     return map lc, split /[ \t?,()]+/, $pkgs;
 442 }
 443
 444
 445 =head2 bug_archiveable
 446
 447      bug_archiveable(ref => $bug_num);
 448
 449 Options
 450
 451 =over
 452
 453 =item ref -- bug number (required)
 454
 455 =item status -- Status hashref (optional)
 456
 457 =item version -- Debbugs::Version information (optional)
 458
 459 =item days_until -- return days until the bug can be archived
 460
 461 =back
 462
 463 Returns 1 if the bug can be archived
 464 Returns 0 if the bug cannot be archived
 465
 466 If days_until is true, returns the number of days until the bug can be
 467 archived, -1 if it cannot be archived.
 468
 469 =cut
 470
 471 sub bug_archiveable{
 472      my %param = validate_with(params => \@_,
 473                                spec   => {ref => {type => SCALAR,
 474                                                   regex => qr/^\d+$/,
 475                                                  },
 476                                           status => {type => HASHREF,
 477                                                      optional => 1,
 478                                                     },
 479                                           version => {type => HASHREF,
 480                                                       optional => 1,
 481                                                      },
 482                                           days_until => {type => BOOLEAN,
 483                                                          default => 0,
 484                                                         },
 485                                          },
 486                               );
 487      # read the status information
 488      # read the version information
 489      # Bugs can be archived if they are
 490      # 1. Closed
 491      # 2. Fixed in unstable if tagged unstable
 492      # 3. Fixed in stable if tagged stable
 493      # 4. Fixed in testing if tagged testing
 494      # 5. Fixed in experimental if tagged experimental
 495      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 496 }
 497
 498 =head1 PRIVATE FUNCTIONS
 499
 500 =cut
 501
 502 sub update_realtime {
 503         my ($file, $bug, $new) = @_;
 504
 505         # update realtime index.db
 506
 507         open(IDXDB, "<$file") or die "Couldn't open $file";
 508         open(IDXNEW, ">$file.new");
 509
 510         my $line;
 511         my @line;
 512         while($line = <IDXDB>) {
 513                 @line = split /\s/, $line;
 514                 last if ($line[1] >= $bug);
 515                 print IDXNEW $line;
 516                 $line = "";
 517         }
 518
 519         if ($new eq "NOCHANGE") {
 520                 print IDXNEW $line if ($line ne "" && $line[1] == $ref);
 521         } elsif ($new eq "REMOVE") {
 522                 0;
 523         } else {
 524                 print IDXNEW $new;
 525         }
 526         if ($line ne "" && $line[1] > $bug) {
 527                 print IDXNEW $line;
 528                 $line = "";
 529         }
 530
 531         print IDXNEW while(<IDXDB>);
 532
 533         close(IDXNEW);
 534         close(IDXDB);
 535
 536         rename("$file.new", $file);
 537
 538         return $line;
 539 }
 540
 541 sub bughook_archive {
 542         my $ref = shift;
 543         &filelock("debbugs.trace.lock");
 544         &appendfile("debbugs.trace","archive $ref\n");
 545         my $line = update_realtime(
 546                 "$gSpoolDir/index.db.realtime",
 547                 $ref,
 548                 "REMOVE");
 549         update_realtime("$gSpoolDir/index.archive.realtime",
 550                 $ref, $line);
 551         &unfilelock;
 552 }
 553
 554 sub bughook {
 555         my ( $type, $ref, $data ) = @_;
 556         &filelock("debbugs.trace.lock");
 557
 558         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 559
 560         my $whendone = "open";
 561         my $severity = $gDefaultSeverity;
 562         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 563         $pkglist =~ s/^,+//;
 564         $pkglist =~ s/,+$//;
 565         $whendone = "forwarded" if length $data->{forwarded};
 566         $whendone = "done" if length $data->{done};
 567         $severity = $data->{severity} if length $data->{severity};
 568
 569         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 570                         $pkglist, $ref, $data->{date}, $whendone,
 571                         $data->{originator}, $severity, $data->{keywords};
 572
 573         update_realtime("$gSpoolDir/index.db.realtime", $ref, $k);
 574
 575         &unfilelock;
 576 }
 577
 578
 579
 580
 581 1;
 582
 583 __END__