Debbugs/Status.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Status;
  11
  12 =head1 NAME
  13
  14 Debbugs::Status -- Routines for dealing with summary and status files
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::Status;
  19
  20
  21 =head1 DESCRIPTION
  22
  23 This module is a replacement for the parts of errorlib.pl which write
  24 and read status and summary files.
  25
  26 It also contains generic routines for returning information about the
  27 status of a particular bug
  28
  29 =head1 FUNCTIONS
  30
  31 =cut
  32
  33 use warnings;
  34 use strict;
  35
  36 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  37 use base qw(Exporter);
  38
  39 use Params::Validate qw(validate_with :types);
  40 use Debbugs::Common qw(:util :lock :quit :misc);
  41 use Debbugs::Config qw(:config);
  42 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  43 use Debbugs::Packages qw(makesourceversions getversions get_versions binarytosource);
  44 use Debbugs::Versions;
  45 use Debbugs::Versions::Dpkg;
  46 use POSIX qw(ceil);
  47
  48 use List::Util qw(min max);
  49
  50
  51 BEGIN{
  52      $VERSION = 1.00;
  53      $DEBUG = 0 unless defined $DEBUG;
  54
  55      @EXPORT = ();
  56      %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
  57                                 qw(isstrongseverity bug_presence),
  58                                ],
  59                      read   => [qw(readbug read_bug lockreadbug lockreadbugmerge),
  60                                 qw(lock_read_all_merged_bugs),
  61                                ],
  62                      write  => [qw(writebug makestatus unlockwritebug)],
  63                      versions => [qw(addfoundversions addfixedversions),
  64                                   qw(removefoundversions removefixedversions)
  65                                  ],
  66                      hook     => [qw(bughook bughook_archive)],
  67                      fields   => [qw(%fields)],
  68                     );
  69      @EXPORT_OK = ();
  70      Exporter::export_ok_tags(qw(status read write versions hook fields));
  71      $EXPORT_TAGS{all} = [@EXPORT_OK];
  72 }
  73
  74
  75 =head2 readbug
  76
  77      readbug($bug_num,$location)
  78      readbug($bug_num)
  79
  80 Reads a summary file from the archive given a bug number and a bug
  81 location. Valid locations are those understood by L</getbugcomponent>
  82
  83 =cut
  84
  85 # these probably shouldn't be imported by most people, but
  86 # Debbugs::Control needs them, so they're now exportable
  87 our %fields = (originator     => 'submitter',
  88               date           => 'date',
  89               subject        => 'subject',
  90               msgid          => 'message-id',
  91               'package'      => 'package',
  92               keywords       => 'tags',
  93               done           => 'done',
  94               forwarded      => 'forwarded-to',
  95               mergedwith     => 'merged-with',
  96               severity       => 'severity',
  97               owner          => 'owner',
  98               found_versions => 'found-in',
  99               found_date     => 'found-date',
 100               fixed_versions => 'fixed-in',
 101               fixed_date     => 'fixed-date',
 102               blocks         => 'blocks',
 103               blockedby      => 'blocked-by',
 104               unarchived     => 'unarchived',
 105               summary        => 'summary',
 106               affects        => 'affects',
 107              );
 108
 109 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
 110 my @rfc1522_fields = qw(originator subject done forwarded owner);
 111
 112 sub readbug {
 113      return read_bug(bug => $_[0],
 114                      (@_ > 1)?(location => $_[1]):()
 115                     );
 116 }
 117
 118 =head2 read_bug
 119
 120      read_bug(bug => $bug_num,
 121               location => 'archive',
 122              );
 123      read_bug(summary => 'path/to/bugnum.summary');
 124      read_bug($bug_num);
 125
 126 A more complete function than readbug; it enables you to pass a full
 127 path to the summary file instead of the bug number and/or location.
 128
 129 =head3 Options
 130
 131 =over
 132
 133 =item bug -- the bug number
 134
 135 =item location -- optional location which is passed to getbugcomponent
 136
 137 =item summary -- complete path to the .summary file which will be read
 138
 139 =item lock -- whether to obtain a lock for the bug to prevent
 140 something modifying it while the bug has been read. You B<must> call
 141 C<unfilelock();> if something not undef is returned from read_bug.
 142
 143 =back
 144
 145 One of C<bug> or C<summary> must be passed. This function will return
 146 undef on failure, and will die if improper arguments are passed.
 147
 148 =cut
 149
 150 sub read_bug{
 151     if (@_ == 1) {
 152          unshift @_, 'bug';
 153     }
 154     my %param = validate_with(params => \@_,
 155                               spec   => {bug => {type => SCALAR,
 156                                                  optional => 1,
 157                                                  # something really
 158                                                  # stupid passes
 159                                                  # negative bugnumbers
 160                                                  regex    => qr/^-?\d+/,
 161                                                 },
 162                                          location => {type => SCALAR|UNDEF,
 163                                                       optional => 1,
 164                                                      },
 165                                          summary  => {type => SCALAR,
 166                                                       optional => 1,
 167                                                      },
 168                                          lock     => {type => BOOLEAN,
 169                                                       optional => 1,
 170                                                      },
 171                                         },
 172                              );
 173     die "One of bug or summary must be passed to read_bug"
 174          if not exists $param{bug} and not exists $param{summary};
 175     my $status;
 176     my $log;
 177     my $location;
 178     if (not defined $param{summary}) {
 179          my $lref;
 180          ($lref,$location) = @param{qw(bug location)};
 181          if (not defined $location) {
 182               $location = getbuglocation($lref,'summary');
 183               return undef if not defined $location;
 184          }
 185          $status = getbugcomponent($lref, 'summary', $location);
 186          $log    = getbugcomponent($lref, 'log'    , $location);
 187          return undef unless defined $status;
 188          return undef if not -e $status;
 189     }
 190     else {
 191          $status = $param{summary};
 192          $log = $status;
 193          $log =~ s/\.summary$/.log/;
 194          ($location) = $status =~ m/(db-h|db|archive)/;
 195     }
 196     if ($param{lock}) {
 197         filelock("$config{spool_dir}/lock/$param{bug}");
 198     }
 199     my $status_fh = IO::File->new($status, 'r');
 200     if (not defined $status_fh) {
 201         warn "Unable to open $status for reading: $!";
 202         if ($param{lock}) {
 203             unfilelock();
 204         }
 205         return undef;
 206     }
 207
 208     my %data;
 209     my @lines;
 210     my $version = 2;
 211     local $_;
 212
 213     while (<$status_fh>) {
 214         chomp;
 215         push @lines, $_;
 216         $version = $1 if /^Format-Version: ([0-9]+)/i;
 217     }
 218
 219     # Version 3 is the latest format version currently supported.
 220     if ($version > 3) {
 221          warn "Unsupported status version '$version'";
 222          if ($param{lock}) {
 223              unfilelock();
 224          }
 225          return undef;
 226     }
 227
 228     my %namemap = reverse %fields;
 229     for my $line (@lines) {
 230         if ($line =~ /(\S+?): (.*)/) {
 231             my ($name, $value) = (lc $1, $2);
 232             $data{$namemap{$name}} = $value if exists $namemap{$name};
 233         }
 234     }
 235     for my $field (keys %fields) {
 236         $data{$field} = '' unless exists $data{$field};
 237     }
 238
 239     $data{severity} = $config{default_severity} if $data{severity} eq '';
 240     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 241          $data{$field} = [split ' ', $data{$field}];
 242     }
 243     for my $field (qw(found fixed)) {
 244          # create the found/fixed hashes which indicate when a
 245          # particular version was marked found or marked fixed.
 246          @{$data{$field}}{@{$data{"${field}_versions"}}} =
 247               (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
 248                @{$data{"${field}_date"}});
 249     }
 250
 251     if ($version < 3) {
 252         for my $field (@rfc1522_fields) {
 253             $data{$field} = decode_rfc1522($data{$field});
 254         }
 255     }
 256     my $status_modified = (stat($status))[9];
 257     # Add log last modified time
 258     $data{log_modified} = (stat($log))[9];
 259     $data{last_modified} = max($status_modified,$data{log_modified});
 260     $data{location} = $location;
 261     $data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
 262     $data{bug_num} = $param{bug};
 263
 264     return \%data;
 265 }
 266
 267 =head2 lockreadbug
 268
 269      lockreadbug($bug_num,$location)
 270
 271 Performs a filelock, then reads the bug; the bug is unlocked if the
 272 return is undefined, otherwise, you need to call unfilelock or
 273 unlockwritebug.
 274
 275 See readbug above for information on what this returns
 276
 277 =cut
 278
 279 sub lockreadbug {
 280     my ($lref, $location) = @_;
 281     return read_bug(bug => $lref, location => $location, lock => 1);
 282 }
 283
 284 =head2 lockreadbugmerge
 285
 286      my ($locks, $data) = lockreadbugmerge($bug_num,$location);
 287
 288 Performs a filelock, then reads the bug. If the bug is merged, locks
 289 the merge lock. Returns a list of the number of locks and the bug
 290 data.
 291
 292 =cut
 293
 294 sub lockreadbugmerge {
 295      my ($bug_num,$location) = @_;
 296      my $data = lockreadbug(@_);
 297      if (not defined $data) {
 298           return (0,undef);
 299      }
 300      if (not length $data->{mergedwith}) {
 301           return (1,$data);
 302      }
 303      unfilelock();
 304      filelock("$config{spool_dir}/lock/merge");
 305      $data = lockreadbug(@_);
 306      if (not defined $data) {
 307           unfilelock();
 308           return (0,undef);
 309      }
 310      return (2,$data);
 311 }
 312
 313 =head2 lock_read_all_merged_bugs
 314
 315      my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location);
 316
 317 Performs a filelock, then reads the bug passed. If the bug is merged,
 318 locks the merge lock, then reads and locks all of the other merged
 319 bugs. Returns a list of the number of locks and the bug data for all
 320 of the merged bugs.
 321
 322 Will also return undef if any of the merged bugs failed to be read,
 323 even if all of the others were read properly.
 324
 325 =cut
 326
 327 sub lock_read_all_merged_bugs {
 328     my ($bug_num,$location) = @_;
 329     my $locks = 0;
 330     my @data = (lockreadbug(@_));
 331     if (not @data or not defined $data[0]) {
 332         return ($locks,undef);
 333     }
 334     $locks++;
 335     if (not length $data[0]->{mergedwith}) {
 336         return ($locks,@data);
 337     }
 338     unfilelock();
 339     $locks--;
 340     filelock("$config{spool_dir}/lock/merge");
 341     $locks++;
 342     @data = (lockreadbug(@_));
 343     if (not @data or not defined $data[0]) {
 344         unfilelock(); #for merge lock above
 345         $locks--;
 346         return ($locks,undef);
 347     }
 348     $locks++;
 349     my @bugs = split / /, $data[0]->{mergedwith};
 350     for my $bug (@bugs) {
 351         my $newdata = undef;
 352         if ($bug ne $bug_num) {
 353             $newdata = lockreadbug($bug,$location);
 354             if (not defined $newdata) {
 355                 for (1..$locks) {
 356                     unfilelock();
 357                 }
 358                 $locks = 0;
 359                 warn "Unable to read bug: $bug while handling merged bug: $bug_num";
 360                 return ($locks,undef);
 361             }
 362             $locks++;
 363             push @data,$newdata;
 364         }
 365         # perform a sanity check to make sure that the merged bugs are
 366         # all merged with eachother
 367         my $expectmerge= join(' ',grep {$_ != $bug } sort { $a <=> $b } (@bugs,$bug_num));
 368         if ($newdata->{mergedwith} ne $expectmerge) {
 369             for (1..$locks) {
 370                 unfilelock();
 371             }
 372             die "Bug $bug_num differs from bug $bug: ($newdata->{bug_num}: $newdata->{mergedwith}) vs. ($expectmerge) (".join(' ',@bugs).")";
 373         }
 374     }
 375     return ($locks,@data);
 376 }
 377
 378
 379 my @v1fieldorder = qw(originator date subject msgid package
 380                       keywords done forwarded mergedwith severity);
 381
 382 =head2 makestatus
 383
 384      my $content = makestatus($status,$version)
 385      my $content = makestatus($status);
 386
 387 Creates the content for a status file based on the $status hashref
 388 passed.
 389
 390 Really only useful for writebug
 391
 392 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 393 eventually default to version 3. If you care, you should specify a
 394 version.
 395
 396 =cut
 397
 398 sub makestatus {
 399     my ($data,$version) = @_;
 400     $version = 2 unless defined $version;
 401
 402     my $contents = '';
 403
 404     my %newdata = %$data;
 405     for my $field (qw(found fixed)) {
 406          if (exists $newdata{$field}) {
 407               $newdata{"${field}_date"} =
 408                    [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
 409          }
 410     }
 411
 412     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 413          $newdata{$field} = join ' ', @{$newdata{$field}||[]};
 414     }
 415
 416     if ($version < 3) {
 417         for my $field (@rfc1522_fields) {
 418             $newdata{$field} = encode_rfc1522($newdata{$field});
 419         }
 420     }
 421
 422     if ($version == 1) {
 423         for my $field (@v1fieldorder) {
 424             if (exists $newdata{$field} and defined $newdata{$field}) {
 425                 $contents .= "$newdata{$field}\n";
 426             } else {
 427                 $contents .= "\n";
 428             }
 429         }
 430     } elsif ($version == 2 or $version == 3) {
 431         # Version 2 or 3. Add a file format version number for the sake of
 432         # further extensibility in the future.
 433         $contents .= "Format-Version: $version\n";
 434         for my $field (keys %fields) {
 435             if (exists $newdata{$field} and defined $newdata{$field}
 436                 and $newdata{$field} ne '') {
 437                 # Output field names in proper case, e.g. 'Merged-With'.
 438                 my $properfield = $fields{$field};
 439                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 440                 $contents .= "$properfield: $newdata{$field}\n";
 441             }
 442         }
 443     }
 444
 445     return $contents;
 446 }
 447
 448 =head2 writebug
 449
 450      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 451
 452 Writes the bug status and summary files out.
 453
 454 Skips writting out a status file if minversion is 2
 455
 456 Does not call bughook if disablebughook is true.
 457
 458 =cut
 459
 460 sub writebug {
 461     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 462     my $change;
 463
 464     my %outputs = (1 => 'status', 2 => 'summary');
 465     for my $version (keys %outputs) {
 466         next if defined $minversion and $version < $minversion;
 467         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 468         die "can't find location for $ref" unless defined $status;
 469         open(S,"> $status.new") || die "opening $status.new: $!";
 470         print(S makestatus($data, $version)) ||
 471             die "writing $status.new: $!";
 472         close(S) || die "closing $status.new: $!";
 473         if (-e $status) {
 474             $change = 'change';
 475         } else {
 476             $change = 'new';
 477         }
 478         rename("$status.new",$status) || die "installing new $status: $!";
 479     }
 480
 481     # $disablebughook is a bit of a hack to let format migration scripts use
 482     # this function rather than having to duplicate it themselves.
 483     &bughook($change,$ref,$data) unless $disablebughook;
 484 }
 485
 486 =head2 unlockwritebug
 487
 488      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 489
 490 Writes a bug, then calls unfilelock; see writebug for what these
 491 options mean.
 492
 493 =cut
 494
 495 sub unlockwritebug {
 496     writebug(@_);
 497     &unfilelock;
 498 }
 499
 500 =head1 VERSIONS
 501
 502 The following functions are exported with the :versions tag
 503
 504 =head2 addfoundversions
 505
 506      addfoundversions($status,$package,$version,$isbinary);
 507
 508
 509
 510 =cut
 511
 512
 513 sub addfoundversions {
 514     my $data = shift;
 515     my $package = shift;
 516     my $version = shift;
 517     my $isbinary = shift;
 518     return unless defined $version;
 519     undef $package if $package =~ m[(?:\s|/)];
 520     my $source = $package;
 521
 522     if (defined $package and $isbinary) {
 523         my @srcinfo = binarytosource($package, $version, undef);
 524         if (@srcinfo) {
 525             # We know the source package(s). Use a fully-qualified version.
 526             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 527             return;
 528         }
 529         # Otherwise, an unqualified version will have to do.
 530         undef $source;
 531     }
 532
 533     # Strip off various kinds of brain-damage.
 534     $version =~ s/;.*//;
 535     $version =~ s/ *\(.*\)//;
 536     $version =~ s/ +[A-Za-z].*//;
 537
 538     foreach my $ver (split /[,\s]+/, $version) {
 539         my $sver = defined($source) ? "$source/$ver" : '';
 540         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 541             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 542         }
 543         @{$data->{fixed_versions}} =
 544             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 545     }
 546 }
 547
 548 =head2 removefoundversions
 549
 550      removefoundversions($data,$package,$versiontoremove)
 551
 552 Removes found versions from $data
 553
 554 If a version is fully qualified (contains /) only versions matching
 555 exactly are removed. Otherwise, all versions matching the version
 556 number are removed.
 557
 558 Currently $package and $isbinary are entirely ignored, but accepted
 559 for backwards compatibilty.
 560
 561 =cut
 562
 563 sub removefoundversions {
 564     my $data = shift;
 565     my $package = shift;
 566     my $version = shift;
 567     my $isbinary = shift;
 568     return unless defined $version;
 569
 570     foreach my $ver (split /[,\s]+/, $version) {
 571          if ($ver =~ m{/}) {
 572               # fully qualified version
 573               @{$data->{found_versions}} =
 574                    grep {$_ ne $ver}
 575                         @{$data->{found_versions}};
 576          }
 577          else {
 578               # non qualified version; delete all matchers
 579               @{$data->{found_versions}} =
 580                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 581                         @{$data->{found_versions}};
 582          }
 583     }
 584 }
 585
 586
 587 sub addfixedversions {
 588     my $data = shift;
 589     my $package = shift;
 590     my $version = shift;
 591     my $isbinary = shift;
 592     return unless defined $version;
 593     undef $package if defined $package and $package =~ m[(?:\s|/)];
 594     my $source = $package;
 595
 596     if (defined $package and $isbinary) {
 597         my @srcinfo = binarytosource($package, $version, undef);
 598         if (@srcinfo) {
 599             # We know the source package(s). Use a fully-qualified version.
 600             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 601             return;
 602         }
 603         # Otherwise, an unqualified version will have to do.
 604         undef $source;
 605     }
 606
 607     # Strip off various kinds of brain-damage.
 608     $version =~ s/;.*//;
 609     $version =~ s/ *\(.*\)//;
 610     $version =~ s/ +[A-Za-z].*//;
 611
 612     foreach my $ver (split /[,\s]+/, $version) {
 613         my $sver = defined($source) ? "$source/$ver" : '';
 614         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 615             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 616         }
 617         @{$data->{found_versions}} =
 618             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 619     }
 620 }
 621
 622 sub removefixedversions {
 623     my $data = shift;
 624     my $package = shift;
 625     my $version = shift;
 626     my $isbinary = shift;
 627     return unless defined $version;
 628
 629     foreach my $ver (split /[,\s]+/, $version) {
 630          if ($ver =~ m{/}) {
 631               # fully qualified version
 632               @{$data->{fixed_versions}} =
 633                    grep {$_ ne $ver}
 634                         @{$data->{fixed_versions}};
 635          }
 636          else {
 637               # non qualified version; delete all matchers
 638               @{$data->{fixed_versions}} =
 639                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 640                         @{$data->{fixed_versions}};
 641          }
 642     }
 643 }
 644
 645
 646
 647 =head2 splitpackages
 648
 649      splitpackages($pkgs)
 650
 651 Split a package string from the status file into a list of package names.
 652
 653 =cut
 654
 655 sub splitpackages {
 656     my $pkgs = shift;
 657     return unless defined $pkgs;
 658     return map lc, split /[ \t?,()]+/, $pkgs;
 659 }
 660
 661
 662 =head2 bug_archiveable
 663
 664      bug_archiveable(bug => $bug_num);
 665
 666 Options
 667
 668 =over
 669
 670 =item bug -- bug number (required)
 671
 672 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 673
 674 =item version -- Debbugs::Version information (optional)
 675
 676 =item days_until -- return days until the bug can be archived
 677
 678 =back
 679
 680 Returns 1 if the bug can be archived
 681 Returns 0 if the bug cannot be archived
 682
 683 If days_until is true, returns the number of days until the bug can be
 684 archived, -1 if it cannot be archived. 0 means that the bug can be
 685 archived the next time the archiver runs.
 686
 687 Returns undef on failure.
 688
 689 =cut
 690
 691 # This will eventually need to be fixed before we start using mod_perl
 692 our $version_cache = {};
 693 sub bug_archiveable{
 694      my %param = validate_with(params => \@_,
 695                                spec   => {bug => {type => SCALAR,
 696                                                   regex => qr/^\d+$/,
 697                                                  },
 698                                           status => {type => HASHREF,
 699                                                      optional => 1,
 700                                                     },
 701                                           days_until => {type => BOOLEAN,
 702                                                          default => 0,
 703                                                         },
 704                                           ignore_time => {type => BOOLEAN,
 705                                                           default => 0,
 706                                                          },
 707                                          },
 708                               );
 709      # This is what we return if the bug cannot be archived.
 710      my $cannot_archive = $param{days_until}?-1:0;
 711      # read the status information
 712      my $status = $param{status};
 713      if (not exists $param{status} or not defined $status) {
 714           $status = read_bug(bug=>$param{bug});
 715           if (not defined $status) {
 716                print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
 717                return undef;
 718           }
 719      }
 720      # Bugs can be archived if they are
 721      # 1. Closed
 722      if (not defined $status->{done} or not length $status->{done}) {
 723           print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
 724           return $cannot_archive
 725      }
 726      # Check to make sure that the bug has none of the unremovable tags set
 727      if (@{$config{removal_unremovable_tags}}) {
 728           for my $tag (split ' ', ($status->{tags}||'')) {
 729                if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
 730                     print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
 731                     return $cannot_archive;
 732                }
 733           }
 734      }
 735
 736      # If we just are checking if the bug can be archived, we'll not even bother
 737      # checking the versioning information if the bug has been -done for less than 28 days.
 738      my $log_file = getbugcomponent($param{bug},'log');
 739      if (not defined $log_file) {
 740           print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
 741           return $cannot_archive;
 742      }
 743      my $max_log_age = max(map {$config{remove_age} - -M $_}
 744                            $log_file, map {my $log = getbugcomponent($_,'log');
 745                                            defined $log ? ($log) : ();
 746                                       }
 747                            split / /, $status->{mergedwith}
 748                        );
 749      if (not $param{days_until} and not $param{ignore_time}
 750          and $max_log_age > 0
 751         ) {
 752           print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
 753           return $cannot_archive;
 754      }
 755      # At this point, we have to get the versioning information for this bug.
 756      # We examine the set of distribution tags. If a bug has no distribution
 757      # tags set, we assume a default set, otherwise we use the tags the bug
 758      # has set.
 759
 760      # In cases where we are assuming a default set, if the severity
 761      # is strong, we use the strong severity default; otherwise, we
 762      # use the normal default.
 763
 764      # There must be fixed_versions for us to look at the versioning
 765      # information
 766      my $min_fixed_time = time;
 767      my $min_archive_days = 0;
 768      if (@{$status->{fixed_versions}}) {
 769           my %dist_tags;
 770           @dist_tags{@{$config{removal_distribution_tags}}} =
 771                (1) x @{$config{removal_distribution_tags}};
 772           my %dists;
 773           for my $tag (split ' ', ($status->{tags}||'')) {
 774                next unless exists $config{distribution_aliases}{$tag};
 775                next unless $dist_tags{$config{distribution_aliases}{$tag}};
 776                $dists{$config{distribution_aliases}{$tag}} = 1;
 777           }
 778           if (not keys %dists) {
 779                if (isstrongseverity($status->{severity})) {
 780                     @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
 781                          (1) x @{$config{removal_strong_severity_default_distribution_tags}};
 782                }
 783                else {
 784                     @dists{@{$config{removal_default_distribution_tags}}} =
 785                          (1) x @{$config{removal_default_distribution_tags}};
 786                }
 787           }
 788           my %source_versions;
 789           my @sourceversions = get_versions(package => $status->{package},
 790                                             dist => [keys %dists],
 791                                             source => 1,
 792                                            );
 793           @source_versions{@sourceversions} = (1) x @sourceversions;
 794           # If the bug has not been fixed in the versions actually
 795           # distributed, then it cannot be archived.
 796           if ('found' eq max_buggy(bug => $param{bug},
 797                                    sourceversions => [keys %source_versions],
 798                                    found          => $status->{found_versions},
 799                                    fixed          => $status->{fixed_versions},
 800                                    version_cache  => $version_cache,
 801                                    package        => $status->{package},
 802                                   )) {
 803                print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
 804                return $cannot_archive;
 805           }
 806           # Since the bug has at least been fixed in the architectures
 807           # that matters, we check to see how long it has been fixed.
 808
 809           # If $param{ignore_time}, then we should ignore time.
 810           if ($param{ignore_time}) {
 811                return $param{days_until}?0:1;
 812           }
 813
 814           # To do this, we order the times from most recent to oldest;
 815           # when we come to the first found version, we stop.
 816           # If we run out of versions, we only report the time of the
 817           # last one.
 818           my %time_versions = get_versions(package => $status->{package},
 819                                            dist    => [keys %dists],
 820                                            source  => 1,
 821                                            time    => 1,
 822                                           );
 823           for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
 824                my $buggy = buggy(bug => $param{bug},
 825                                  version        => $version,
 826                                  found          => $status->{found_versions},
 827                                  fixed          => $status->{fixed_versions},
 828                                  version_cache  => $version_cache,
 829                                  package        => $status->{package},
 830                                 );
 831                last if $buggy eq 'found';
 832                $min_fixed_time = min($time_versions{$version},$min_fixed_time);
 833           }
 834           $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
 835                # if there are no versions in the archive at all, then
 836                # we can archive if enough days have passed
 837                if @sourceversions;
 838      }
 839      # If $param{ignore_time}, then we should ignore time.
 840      if ($param{ignore_time}) {
 841           return $param{days_until}?0:1;
 842      }
 843      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 844      my $age = ceil($max_log_age);
 845      if ($age > 0 or $min_archive_days > 0) {
 846           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
 847           return $param{days_until}?max($age,$min_archive_days):0;
 848      }
 849      else {
 850           return $param{days_until}?0:1;
 851      }
 852 }
 853
 854
 855 =head2 get_bug_status
 856
 857      my $status = get_bug_status(bug => $nnn);
 858
 859      my $status = get_bug_status($bug_num)
 860
 861 =head3 Options
 862
 863 =over
 864
 865 =item bug -- scalar bug number
 866
 867 =item status -- optional hashref of bug status as returned by readbug
 868 (can be passed to avoid rereading the bug information)
 869
 870 =item bug_index -- optional tied index of bug status infomration;
 871 currently not correctly implemented.
 872
 873 =item version -- optional version(s) to check package status at
 874
 875 =item dist -- optional distribution(s) to check package status at
 876
 877 =item arch -- optional architecture(s) to check package status at
 878
 879 =item bugusertags -- optional hashref of bugusertags
 880
 881 =item sourceversion -- optional arrayref of source/version; overrides
 882 dist, arch, and version. [The entries in this array must be in the
 883 "source/version" format.] Eventually this can be used to for caching.
 884
 885 =item indicatesource -- if true, indicate which source packages this
 886 bug could belong to (or does belong to in the case of bugs assigned to
 887 a source package). Defaults to true.
 888
 889 =back
 890
 891 Note: Currently the version information is cached; this needs to be
 892 changed before using this function in long lived programs.
 893
 894 =cut
 895
 896 sub get_bug_status {
 897      if (@_ == 1) {
 898           unshift @_, 'bug';
 899      }
 900      my %param = validate_with(params => \@_,
 901                                spec   => {bug       => {type => SCALAR,
 902                                                         regex => qr/^\d+$/,
 903                                                        },
 904                                           status    => {type => HASHREF,
 905                                                         optional => 1,
 906                                                        },
 907                                           bug_index => {type => OBJECT,
 908                                                         optional => 1,
 909                                                        },
 910                                           version   => {type => SCALAR|ARRAYREF,
 911                                                         optional => 1,
 912                                                        },
 913                                           dist       => {type => SCALAR|ARRAYREF,
 914                                                          optional => 1,
 915                                                         },
 916                                           arch       => {type => SCALAR|ARRAYREF,
 917                                                          optional => 1,
 918                                                         },
 919                                           bugusertags   => {type => HASHREF,
 920                                                             optional => 1,
 921                                                            },
 922                                           sourceversions => {type => ARRAYREF,
 923                                                              optional => 1,
 924                                                             },
 925                                           indicatesource => {type => BOOLEAN,
 926                                                              default => 1,
 927                                                             },
 928                                          },
 929                               );
 930      my %status;
 931
 932      if (defined $param{bug_index} and
 933          exists $param{bug_index}{$param{bug}}) {
 934           %status = %{ $param{bug_index}{$param{bug}} };
 935           $status{pending} = $status{ status };
 936           $status{id} = $param{bug};
 937           return \%status;
 938      }
 939      if (defined $param{status}) {
 940           %status = %{$param{status}};
 941      }
 942      else {
 943           my $location = getbuglocation($param{bug}, 'summary');
 944           return {} if not defined $location or not length $location;
 945           %status = %{ readbug( $param{bug}, $location ) };
 946      }
 947      $status{id} = $param{bug};
 948
 949      if (defined $param{bugusertags}{$param{bug}}) {
 950           $status{keywords} = "" unless defined $status{keywords};
 951           $status{keywords} .= " " unless $status{keywords} eq "";
 952           $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
 953      }
 954      $status{tags} = $status{keywords};
 955      my %tags = map { $_ => 1 } split ' ', $status{tags};
 956
 957      $status{package} = '' if not defined $status{package};
 958      $status{"package"} =~ s/\s*$//;
 959      # if we aren't supposed to indicate the source, we'll return
 960      # unknown here.
 961      $status{source} = 'unknown';
 962      if ($param{indicatesource}) {
 963          my @packages = split /\s*,\s*/, $status{package};
 964          my @source;
 965          for my $package (@packages) {
 966              next if $package eq '';
 967              if ($package =~ /^src\:$/) {
 968                  push @source,$1;
 969              }
 970              else {
 971                  push @source, binarytosource($package);
 972              }
 973          }
 974          if (@source) {
 975              $status{source} = join(', ',@source);
 976          }
 977      }
 978
 979      $status{"package"} = 'unknown' if ($status{"package"} eq '');
 980      $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
 981
 982      $status{"pending"} = 'pending';
 983      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
 984      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 985      $status{"pending"} = 'fixed'           if ($tags{fixed});
 986
 987
 988      my $presence = bug_presence(status => \%status,
 989                                  map{(exists $param{$_})?($_,$param{$_}):()}
 990                                  qw(bug sourceversions arch dist version found fixed package)
 991                                 );
 992      if (defined $presence) {
 993           if ($presence eq 'fixed') {
 994                $status{pending} = 'done';
 995           }
 996           elsif ($presence eq 'absent') {
 997                $status{pending} = 'absent';
 998           }
 999      }
1000      return \%status;
1001 }
1002
1003 =head2 bug_presence
1004
1005      my $precence = bug_presence(bug => nnn,
1006                                  ...
1007                                 );
1008
1009 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1010 is found, absent, fixed, or no information is available in the
1011 distribution (dist) and/or architecture (arch) specified.
1012
1013
1014 =head3 Options
1015
1016 =over
1017
1018 =item bug -- scalar bug number
1019
1020 =item status -- optional hashref of bug status as returned by readbug
1021 (can be passed to avoid rereading the bug information)
1022
1023 =item bug_index -- optional tied index of bug status infomration;
1024 currently not correctly implemented.
1025
1026 =item version -- optional version to check package status at
1027
1028 =item dist -- optional distribution to check package status at
1029
1030 =item arch -- optional architecture to check package status at
1031
1032 =item sourceversion -- optional arrayref of source/version; overrides
1033 dist, arch, and version. [The entries in this array must be in the
1034 "source/version" format.] Eventually this can be used to for caching.
1035
1036 =back
1037
1038 =cut
1039
1040 sub bug_presence {
1041      my %param = validate_with(params => \@_,
1042                                spec   => {bug       => {type => SCALAR,
1043                                                         regex => qr/^\d+$/,
1044                                                        },
1045                                           status    => {type => HASHREF,
1046                                                         optional => 1,
1047                                                        },
1048                                           version   => {type => SCALAR|ARRAYREF,
1049                                                         optional => 1,
1050                                                        },
1051                                           dist       => {type => SCALAR|ARRAYREF,
1052                                                          optional => 1,
1053                                                         },
1054                                           arch       => {type => SCALAR|ARRAYREF,
1055                                                          optional => 1,
1056                                                         },
1057                                           sourceversions => {type => ARRAYREF,
1058                                                              optional => 1,
1059                                                             },
1060                                          },
1061                               );
1062      my %status;
1063      if (defined $param{status}) {
1064          %status = %{$param{status}};
1065      }
1066      else {
1067           my $location = getbuglocation($param{bug}, 'summary');
1068           return {} if not length $location;
1069           %status = %{ readbug( $param{bug}, $location ) };
1070      }
1071
1072      my @sourceversions;
1073      my $pseudo_desc = getpseudodesc();
1074      if (not exists $param{sourceversions}) {
1075           my %sourceversions;
1076           # pseudopackages do not have source versions by definition.
1077           if (exists $pseudo_desc->{$status{package}}) {
1078                # do nothing.
1079           }
1080           elsif (defined $param{version}) {
1081                foreach my $arch (make_list($param{arch})) {
1082                     for my $package (split /\s*,\s*/, $status{package}) {
1083                          my @temp = makesourceversions($package,
1084                                                        $arch,
1085                                                        make_list($param{version})
1086                                                       );
1087                          @sourceversions{@temp} = (1) x @temp;
1088                     }
1089                }
1090           } elsif (defined $param{dist}) {
1091                my %affects_distribution_tags;
1092                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1093                     (1) x @{$config{affects_distribution_tags}};
1094                my $some_distributions_disallowed = 0;
1095                my %allowed_distributions;
1096                for my $tag (split ' ', ($status{tags}||'')) {
1097                    if (exists $config{distribution_aliases}{$tag} and
1098                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1099                        $some_distributions_disallowed = 1;
1100                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1101                    }
1102                    elsif (exists $affects_distribution_tags{$tag}) {
1103                        $some_distributions_disallowed = 1;
1104                        $allowed_distributions{$tag} = 1;
1105                    }
1106                }
1107                foreach my $arch (make_list($param{arch})) {
1108                     for my $package (split /\s*,\s*/, $status{package}) {
1109                          my @versions;
1110                          foreach my $dist (make_list($param{dist})) {
1111                               # if some distributions are disallowed,
1112                               # and this isn't an allowed
1113                               # distribution, then we ignore this
1114                               # distribution for the purposees of
1115                               # finding versions
1116                               if ($some_distributions_disallowed and
1117                                   not exists $allowed_distributions{$dist}) {
1118                                    next;
1119                               }
1120                               push @versions, getversions($package, $dist, $arch);
1121                          }
1122                          next unless @versions;
1123                          my @temp = makesourceversions($package,
1124                                                        $arch,
1125                                                        @versions
1126                                                       );
1127                          @sourceversions{@temp} = (1) x @temp;
1128                     }
1129                }
1130           }
1131
1132           # TODO: This should probably be handled further out for efficiency and
1133           # for more ease of distinguishing between pkg= and src= queries.
1134           # DLA: src= queries should just pass arch=source, and they'll be happy.
1135           @sourceversions = keys %sourceversions;
1136      }
1137      else {
1138           @sourceversions = @{$param{sourceversions}};
1139      }
1140      my $maxbuggy = 'undef';
1141      if (@sourceversions) {
1142           $maxbuggy = max_buggy(bug => $param{bug},
1143                                 sourceversions => \@sourceversions,
1144                                 found => $status{found_versions},
1145                                 fixed => $status{fixed_versions},
1146                                 package => $status{package},
1147                                 version_cache => $version_cache,
1148                                );
1149      }
1150      elsif (defined $param{dist} and
1151             not exists $pseudo_desc->{$status{package}}) {
1152           return 'absent';
1153      }
1154      if (length($status{done}) and
1155          (not @sourceversions or not @{$status{fixed_versions}})) {
1156           return 'fixed';
1157      }
1158      return $maxbuggy;
1159 }
1160
1161
1162 =head2 max_buggy
1163
1164      max_buggy()
1165
1166 =head3 Options
1167
1168 =over
1169
1170 =item bug -- scalar bug number
1171
1172 =item sourceversion -- optional arrayref of source/version; overrides
1173 dist, arch, and version. [The entries in this array must be in the
1174 "source/version" format.] Eventually this can be used to for caching.
1175
1176 =back
1177
1178 Note: Currently the version information is cached; this needs to be
1179 changed before using this function in long lived programs.
1180
1181
1182 =cut
1183 sub max_buggy{
1184      my %param = validate_with(params => \@_,
1185                                spec   => {bug       => {type => SCALAR,
1186                                                         regex => qr/^\d+$/,
1187                                                        },
1188                                           sourceversions => {type => ARRAYREF,
1189                                                              default => [],
1190                                                             },
1191                                           found          => {type => ARRAYREF,
1192                                                              default => [],
1193                                                             },
1194                                           fixed          => {type => ARRAYREF,
1195                                                              default => [],
1196                                                             },
1197                                           package        => {type => SCALAR,
1198                                                             },
1199                                           version_cache  => {type => HASHREF,
1200                                                              default => {},
1201                                                             },
1202                                          },
1203                               );
1204      # Resolve bugginess states (we might be looking at multiple
1205      # architectures, say). Found wins, then fixed, then absent.
1206      my $maxbuggy = 'absent';
1207      for my $package (split /\s*,\s*/, $param{package}) {
1208           for my $version (@{$param{sourceversions}}) {
1209                my $buggy = buggy(bug => $param{bug},
1210                                  version => $version,
1211                                  found => $param{found},
1212                                  fixed => $param{fixed},
1213                                  version_cache => $param{version_cache},
1214                                  package => $package,
1215                                 );
1216                if ($buggy eq 'found') {
1217                     return 'found';
1218                } elsif ($buggy eq 'fixed') {
1219                     $maxbuggy = 'fixed';
1220                }
1221           }
1222      }
1223      return $maxbuggy;
1224 }
1225
1226
1227 =head2 buggy
1228
1229      buggy(bug => nnn,
1230            found => \@found,
1231            fixed => \@fixed,
1232            package => 'foo',
1233            version => '1.0',
1234           );
1235
1236 Returns the output of Debbugs::Versions::buggy for a particular
1237 package, version and found/fixed set. Automatically turns found, fixed
1238 and version into source/version strings.
1239
1240 Caching can be had by using the version_cache, but no attempt to check
1241 to see if the on disk information is more recent than the cache is
1242 made. [This will need to be fixed for long-lived processes.]
1243
1244 =cut
1245
1246 sub buggy {
1247      my %param = validate_with(params => \@_,
1248                                spec   => {bug => {type => SCALAR,
1249                                                   regex => qr/^\d+$/,
1250                                                  },
1251                                           found => {type => ARRAYREF,
1252                                                     default => [],
1253                                                    },
1254                                           fixed => {type => ARRAYREF,
1255                                                     default => [],
1256                                                    },
1257                                           version_cache => {type => HASHREF,
1258                                                             optional => 1,
1259                                                            },
1260                                           package => {type => SCALAR,
1261                                                      },
1262                                           version => {type => SCALAR,
1263                                                      },
1264                                          },
1265                               );
1266      my @found = @{$param{found}};
1267      my @fixed = @{$param{fixed}};
1268      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1269           # We have non-source version versions
1270           @found = makesourceversions($param{package},undef,
1271                                       @found
1272                                      );
1273           @fixed = makesourceversions($param{package},undef,
1274                                       @fixed
1275                                      );
1276      }
1277      if ($param{version} !~ m{/}) {
1278           my ($version) = makesourceversions($param{package},undef,
1279                                              $param{version}
1280                                             );
1281           $param{version} = $version if defined $version;
1282      }
1283      # Figure out which source packages we need
1284      my %sources;
1285      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1286      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1287      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1288           $param{version} =~ m{/};
1289      my $version;
1290      if (not defined $param{version_cache} or
1291          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1292           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1293           foreach my $source (keys %sources) {
1294                my $srchash = substr $source, 0, 1;
1295                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1296                if (not defined $version_fh) {
1297                     # We only want to warn if it's a package which actually has a maintainer
1298                     my $maints = getmaintainers();
1299                     next if not exists $maints->{$source};
1300                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1301                     next;
1302                }
1303                $version->load($version_fh);
1304           }
1305           if (defined $param{version_cache}) {
1306                $param{version_cache}{join(',',sort keys %sources)} = $version;
1307           }
1308      }
1309      else {
1310           $version = $param{version_cache}{join(',',sort keys %sources)};
1311      }
1312      return $version->buggy($param{version},\@found,\@fixed);
1313 }
1314
1315 sub isstrongseverity {
1316     my $severity = shift;
1317     $severity = $config{default_severity} if
1318          not defined $severity or $severity eq '';
1319     return grep { $_ eq $severity } @{$config{strong_severities}};
1320 }
1321
1322
1323 =head1 PRIVATE FUNCTIONS
1324
1325 =cut
1326
1327 sub update_realtime {
1328         my ($file, %bugs) = @_;
1329
1330         # update realtime index.db
1331
1332         return () unless keys %bugs;
1333         my $idx_old = IO::File->new($file,'r')
1334              or die "Couldn't open ${file}: $!";
1335         my $idx_new = IO::File->new($file.'.new','w')
1336              or die "Couldn't open ${file}.new: $!";
1337
1338         my $min_bug = min(keys %bugs);
1339         my $line;
1340         my @line;
1341         my %changed_bugs;
1342         while($line = <$idx_old>) {
1343              @line = split /\s/, $line;
1344              # Two cases; replacing existing line or adding new line
1345              if (exists $bugs{$line[1]}) {
1346                   my $new = $bugs{$line[1]};
1347                   delete $bugs{$line[1]};
1348                   $min_bug = min(keys %bugs);
1349                   if ($new eq "NOCHANGE") {
1350                        print {$idx_new} $line;
1351                        $changed_bugs{$line[1]} = $line;
1352                   } elsif ($new eq "REMOVE") {
1353                        $changed_bugs{$line[1]} = $line;
1354                   } else {
1355                        print {$idx_new} $new;
1356                        $changed_bugs{$line[1]} = $line;
1357                   }
1358              }
1359              else {
1360                   while ($line[1] > $min_bug) {
1361                        print {$idx_new} $bugs{$min_bug};
1362                        delete $bugs{$min_bug};
1363                        last unless keys %bugs;
1364                        $min_bug = min(keys %bugs);
1365                   }
1366                   print {$idx_new} $line;
1367              }
1368              last unless keys %bugs;
1369         }
1370         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1371
1372         print {$idx_new} <$idx_old>;
1373
1374         close($idx_new);
1375         close($idx_old);
1376
1377         rename("$file.new", $file);
1378
1379         return %changed_bugs;
1380 }
1381
1382 sub bughook_archive {
1383         my @refs = @_;
1384         &filelock("$config{spool_dir}/debbugs.trace.lock");
1385         &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1386         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1387                                    map{($_,'REMOVE')} @refs);
1388         update_realtime("$config{spool_dir}/index.archive.realtime",
1389                         %bugs);
1390         &unfilelock;
1391 }
1392
1393 sub bughook {
1394         my ( $type, %bugs_temp ) = @_;
1395         &filelock("$config{spool_dir}/debbugs.trace.lock");
1396
1397         my %bugs;
1398         for my $bug (keys %bugs_temp) {
1399              my $data = $bugs_temp{$bug};
1400              &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1401
1402              my $whendone = "open";
1403              my $severity = $config{default_severity};
1404              (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1405              $pkglist =~ s/^,+//;
1406              $pkglist =~ s/,+$//;
1407              $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1408              $whendone = "done" if defined $data->{done} and length $data->{done};
1409              $severity = $data->{severity} if length $data->{severity};
1410
1411              my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1412                   $pkglist, $bug, $data->{date}, $whendone,
1413                        $data->{originator}, $severity, $data->{keywords};
1414              $bugs{$bug} = $k;
1415         }
1416         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1417
1418         &unfilelock;
1419 }
1420
1421
1422 1;
1423
1424 __END__