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