scanlib.pm

   1 #! /usr/bin/perl
   2 # vim: ts=4 sw=4 nowrap
   3 #
   4 # General functions for scanning the BTS-database.
   5 # Based on bugscan, written by Richard Braakman <dark@debian.org>,
   6 # which was based on an unknown other script.
   7 #
   8 # Global variables:
   9 #   %comments       - map from bugnumber to bug description
  10 #   %premature      - list of prematurely closed bugreports
  11 #   %exclude        - list of bugreports to exclude from the report
  12 #   %maintainer     - map from packagename to maintainer
  13 #   %section        - map from packagename to section in the FTP-site
  14 #   %packagelist    - map from packagename to bugreports
  15 #   %NMU            - map with NMU information
  16
  17 use lib qw(/org/bugs.debian.org/perl/);
  18 use LWP::UserAgent;
  19 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  20 use Debbugs::Packages;
  21 use Debbugs::Versions;
  22 use Fcntl qw(O_RDONLY);
  23 require bugcfg;
  24
  25 sub readcomments() {
  26 # Read bug commentary
  27 # It is in paragraph format, with the first line of each paragraph being
  28 # the bug number or package name to which the comment applies.
  29 # Prefix a bug number with a * to force it to be listed even if it's closed.
  30 # (This deals with prematurely closed bugs)
  31
  32         local($index);                                  # Bug-number for current comment
  33         local($file);                                   # Name of comments-file
  34
  35         %comments = ();                                 # Initialize our data
  36         %premature = ();
  37         %exclude = ();
  38         $file=shift;
  39         open(C, $file) or die "open $file: $!\n";
  40         while (<C>) {
  41                 chomp;
  42                 if (m/^\s*$/) {                         # Check for paragraph-breaks
  43                         undef $index;
  44                 } elsif (defined $index) {
  45                         $comments{$index} .= $_ . "\n";
  46                 } else {
  47                         if (s/^\*//) {                  # Test & remove initial *
  48                                 $premature{$_} = 1;
  49                         }
  50                         if (s/\s+EXCLUDE\s*//) {        # Test & remove EXCLUDE
  51                                 $exclude{$_} = 1;
  52                                 next;
  53                         }
  54                         $index = $_;
  55                         $comments{$index} = ''; # New comment, initialize data
  56                 }
  57         }
  58         close(C);
  59 }
  60
  61
  62 # Read the list of maintainer
  63 sub readmaintainers() {
  64         local ($pkg);                                   # Name of package
  65         local ($mnt);                                   # Maintainer name & email
  66
  67         open(M, $maintainerlist) or die "open $maintainerlist: $!\n";
  68         while (<M>) {
  69                 chomp;
  70                 m/^(\S+)\s+(\S.*\S)\s*$/ or die "Maintainers: $_ ?";
  71                 ($pkg, $mnt) = ($1, $2);
  72                 $pkg =~ y/A-Z/a-z/;                     # Normalize package-name. why???
  73                 $_=$mnt;
  74                 if (not m/</) {
  75                         $mnt="$2 <$1>" if ( m/(\S+)\s+\(([^)]+)\)/ );
  76                 }
  77                 $maintainer{$pkg}= $mnt;
  78         }
  79         close(M);
  80 }
  81
  82
  83 sub readsources() {
  84         local($root);                                   # Root of archive we are scanning
  85         local($archive);                                # Name of archive we are scanning
  86         local($sect);                                   # Name of current section
  87
  88         $root=shift;
  89         $archive=shift;
  90         for $sect ( @sections) {
  91                 open(P, "zcat $root/$sect/source/Sources.gz|")
  92                         or die open "open: $sect / $arch sourcelist: $!\n";
  93                 while (<P>) {
  94                         chomp;
  95                         next unless m/^Package:\s/;
  96                         s/^Package:\s*//;                       # Strip the fieldname
  97                         $section{$_} = "$archive/$sect";
  98                 }
  99                 close (P);
 100         }
 101 }
 102
 103 sub readpackages() {
 104         local($root);                                   # Root of archive we are scanning
 105         local($archive);                                # Name of archive we are scanning
 106         local($sect);                                   # Name of current section
 107         local($arch);                                   # Name of current architecture
 108
 109         $root=shift;
 110         $archive=shift;
 111         for $arch ( @architectures ) {
 112                 for $sect ( @sections) {
 113                         open(P, "zcat $root/$sect/binary-$arch/Packages.gz|")
 114                                 or die "open: $root/$sect/binary-$arch/Packages.gz: $!\n";
 115                         while (<P>) {
 116                                 chomp;
 117                                 next unless m/^Package:\s/;     # We're only interested in the packagenames
 118                                 s/^Package:\s*//;                       # Strip the fieldname
 119                                 $section{$_} = "$archive/$sect";
 120                         }
 121                         close(P);
 122                 }
 123         }
 124 }
 125
 126 sub readdebbugssources() {
 127         local($file);
 128         local($archive);
 129
 130         $file=shift;
 131         $archive=shift;
 132         open(P, $file)
 133                 or die "open: $file: $!\n";
 134         while (<P>) {
 135                 chomp;
 136                 my ($host, $bin, $sect, $ver, $src) = split /\s+/;
 137                 my $sectname = ($sect =~ /^\Q$archive/) ? $sect : "$archive/$sect";
 138                 $debbugssection{$bin} = $sectname;
 139                 $debbugssection{$src} = $sectname;
 140         }
 141         close(P);
 142 }
 143
 144 sub readpseudopackages() {
 145         open(P, $pseudolist) or die("open $pseudolist: $!\n");
 146         while (<P>) {
 147                 chomp;
 148                 s/\s.*//;
 149                 $section{$_} = "pseudo";
 150         }
 151         close(P);
 152 }
 153
 154
 155 sub scanspool() {
 156         local(@dirs);
 157         local($dir);
 158
 159         chdir($spooldir) or die "chdir $spooldir: $!\n";
 160
 161         opendir(DIR, $spooldir) or die "opendir $spooldir: $!\n";
 162         @dirs=grep(m/^\d+$/,readdir(DIR));
 163         closedir(DIR);
 164
 165         for $dir (@dirs) {
 166                 scanspooldir("$spooldir/$dir");
 167         }
 168
 169 }
 170
 171 sub scanspooldir() {
 172         local($dir)             = @_;
 173         local($f);                      # While we're currently processing
 174         local(@list);           # List of files to process
 175         local($skip);           # Flow control
 176         local($walk);           # index variable
 177         local($taginfo);        # Tag info
 178
 179         chdir($dir) or die "chdir $dir: $!\n";
 180
 181         opendir(DIR, $dir) or die "opendir $dir: $!\n";
 182         @list = grep { s/\.summary$// }
 183                         grep { m/^\d+\.summary$/ }
 184                         readdir(DIR);
 185         closedir(DIR);
 186
 187         for $f (@list) {
 188                 next if $exclude{$f};                   # Check the list of bugs to skip
 189
 190                 my $bug = readbug("$f.summary");
 191                 next if (!defined($bug));
 192
 193                 $skip=1;
 194                 for $walk (@priorities) {
 195                         $skip=0 if $walk eq $bug->{'severity'};
 196                 }
 197
 198                 my @tags = split(' ', $bug->{'keywords'});
 199                 for $tag (@tags) {
 200                         for $s (@skiptags) {
 201                                 $skip=1 if $tag eq $s;
 202                         }
 203                 }
 204                 next if $skip==1;
 205
 206                 my $oldstable_tag    = grep(/^woody$/, @tags);
 207                 my $stable_tag       = grep(/^sarge$/, @tags);
 208                 my $testing_tag      = grep(/^etch$/, @tags);
 209                 my $unstable_tag     = grep(/^sid$/, @tags);
 210                 my $experimental_tag = grep(/^experimental$/, @tags);
 211
 212                 # default according to dondelelcaro 2006-11-11
 213                 if (!$oldstable_tag && !$stable_tag && !$testing_tag && !$unstable_tag && !$experimental_tag) {
 214                         $testing_tag = 1;
 215                         $unstable_tag = 1;
 216                         $experimental_tag = 1;
 217                 }
 218
 219                 # only bother to check the versioning status for the distributions indicated by the tags
 220                 $status_oldstable    = getbugstatus($bug, undef, 'oldstable')    if ($oldstable_tag);
 221                 $status_stable       = getbugstatus($bug, undef, 'stable')       if ($stable_tag);
 222                 $status_testing      = getbugstatus($bug, undef, 'testing')      if ($testing_tag);
 223                 $status_unstable     = getbugstatus($bug, undef, 'unstable')     if ($unstable_tag);
 224                 $status_experimental = getbugstatus($bug, undef, 'experimental') if ($experimental_tag);
 225
 226                 $relinfo = "";
 227                 $relinfo .= (($oldstable_tag    && $status_oldstable->{'pending'}    eq 'pending') ? "O" : "");
 228                 $relinfo .= (($stable_tag       && $status_stable->{'pending'}       eq 'pending') ? "S" : "");
 229                 $relinfo .= (($testing_tag      && $status_testing->{'pending'}      eq 'pending') ? "T" : "");
 230                 $relinfo .= (($unstable_tag     && $status_unstable->{'pending'}     eq 'pending') ? "U" : "");
 231                 $relinfo .= (($experimental_tag && $status_experimental->{'pending'} eq 'pending') ? "E" : "");
 232
 233                 next if $relinfo eq '' and not $premature{$f};
 234                 $premature{$f}++ if $relinfo eq '';
 235
 236                 $taginfo = "[";
 237                 $taginfo .= ($bug->{'keywords'} =~ /\bpending\b/        ? "P" : " ");
 238                 $taginfo .= ($bug->{'keywords'} =~ /\bpatch\b/          ? "+" : " ");
 239                 $taginfo .= ($bug->{'keywords'} =~ /\bhelp\b/           ? "H" : " ");
 240                 $taginfo .= ($bug->{'keywords'} =~ /\bmoreinfo\b/       ? "M" : " ");
 241                 $taginfo .= ($bug->{'keywords'} =~ /\bunreproducible\b/ ? "R" : " ");
 242                 $taginfo .= ($bug->{'keywords'} =~ /\bsecurity\b/       ? "S" : " ");
 243                 $taginfo .= ($bug->{'keywords'} =~ /\bupstream\b/       ? "U" : " ");
 244                 $taginfo .= ($bug->{'keywords'} =~ /\betch-ignore\b/    ? "I" : " ");
 245                 $taginfo .= "]";
 246
 247                 if (length($bug->{'mergedwith'})) {
 248                         my @merged = split(' ', $bug->{'mergedwith'});
 249                         next if ($merged[0] < $f);
 250                 }
 251
 252                 for $package (split /[,\s]+/, $bug->{'package'}) {
 253                         $_= $package; y/A-Z/a-z/; $_= $` if m/[^-+._a-z0-9]/;
 254                         if (not defined $section{$_}) {
 255                                 if (defined $debbugssection{$_}) {
 256                                         $relinfo .= "X";
 257                                 } else {
 258                                         next;   # Skip unavailable packages
 259                                 }
 260                         }
 261
 262                         $packagelist{$_} .= " $f";
 263                 }
 264
 265                 if ($relinfo eq "") { # or $relinfo eq "U" # confuses e.g. #210306
 266                         $relinfo = "";
 267                 } else {
 268                         $relinfo = " [$relinfo]";
 269                 }
 270
 271                 $bugs{$f} = "$f $taginfo$relinfo " . $bug->{'subject'};
 272         }
 273 }
 274
 275
 276 sub readstatus() {
 277         local ($bug);           # Number of current bug
 278         local ($subject);       # Subject for current bug
 279         local ($pkg);           # Name of current package
 280         local ($file);          # Name of statusfile
 281         local ($sect);          # Section of current package
 282         local ($mnt);           # Maintainer of current package
 283
 284         $file=shift;
 285         open(P, $file) or die "open $file: $!";
 286         while (<P>) {
 287                 chomp;
 288                 if (m/^[0-9]+ \[/) {
 289                         ($bug,$subject)=split(/ /, $_, 2);
 290                         $bugs{$bug}=$subject;
 291                         $packagelist{$pkg} .= "$bug ";
 292                 } else {
 293                         ($pkg,$sect, $mnt)=split(/ /, $_, 3);
 294                         $section{$pkg}=$sect;
 295                         $maintainer{$pkg}=$mnt;
 296                 }
 297         }
 298         close P;
 299 }
 300
 301
 302 sub readNMUstatus() {
 303         local ($bug);       # Number of current bug
 304         local ($source);    # Source upload which closes this bug.
 305         local ($version);   # Version where this bug was closed.
 306         local ($flag);      # Whether this paragraph has been processed.
 307         local ($field, $value);
 308
 309         for (split /\n/, LWP::UserAgent->new->request(HTTP::Request->new(GET => shift))->content) {
 310                 chomp;
 311                 if (m/^$/) {
 312                         $NMU{$bug} = 1;
 313                         $NMU{$bug, "source"} = $source;
 314                         $NMU{$bug, "version"} = $version;
 315 #                       $comments{$bug} .= "[FIXED] Fixed package $source is in Incoming\n";
 316                         $flag = 0;
 317                 } else {
 318                         ($field, $value) = split(/: /, $_, 2);
 319                         $bug = $value if($field =~ /bug/i);
 320                         $source = $value if($field =~ /source/i);
 321                         $version = $value if($field =~ /version/i);
 322                         $flag = 1;
 323                 }
 324         }
 325         if ($flag) {
 326                 $NMU{$bug} = 1;
 327                 $NMU{$bug, "source"} = $source;
 328                 $NMU{$bug, "version"} = $version;
 329 #               $comments{$bug} .= "[FIXED] Fixed package $source in in Incoming\n";
 330         }
 331         close P;
 332 }
 333
 334
 335 sub urlsanit {
 336         my $url = shift;
 337         $url =~ s/%/%25/g;
 338         $url =~ s/\+/%2b/g;
 339         my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
 340         $url =~ s/([<>&"])/\&$saniarray{$1};/g;
 341         return $url;
 342 }
 343
 344 sub htmlsanit {
 345     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
 346     my $in = shift || "";
 347     $in =~ s/([<>&"])/\&$saniarray{$1};/g;
 348     return $in;
 349 }
 350
 351 sub wwwnumber() {
 352         local ($number) = shift;                # Number of bug to html-ize
 353 #       local ($section);                               # Section for the bug
 354
 355         "<A HREF=\"http://bugs.debian.org/cgi-bin/bugreport.cgi?archive=no&amp;bug=" .
 356                 urlsanit($number) . '">' . htmlsanit($number) . '</A>';
 357 #       ($section=$number) =~ s/([0-9]{2}).*/$1/;
 358 #       "<A HREF=\"${btsURL}/db/$section/$number.html\">$number</A>";
 359 }
 360
 361 sub wwwname() {
 362         local ($name) = shift;                  # Name of package
 363
 364         "<A HREF=\"http://bugs.debian.org/cgi-bin/pkgreport.cgi?archive=no&amp;pkg=" .
 365                 urlsanit($name) . '">' . htmlsanit($name) . '</A>';
 366 #       "<A HREF=\"${btsURL}/db/pa/l$name.html\">$name</A>";
 367 }
 368
 369 # === everything from here is adapted from debbugs, and should probably be merged
 370 # === back at some point
 371
 372 my %_binarytosource;
 373 my %_binarytosourcecache = ();
 374 sub binarytosource {
 375     my ($binname, $binver, $binarch) = @_;
 376
 377     # TODO: This gets hit a lot, especially from buggyversion() - probably
 378     # need an extra cache for speed here.
 379
 380     if (tied %_binarytosource or
 381             tie %_binarytosource, 'MLDBM',
 382                 $Debbugs::Packages::gBinarySourceMap, O_RDONLY) {
 383                 if (!exists($_binarytosourcecache{$binname})) {
 384                         $_binarytosourcecache{$binname} = \%{ $_binarytosource{$binname} };
 385                 }
 386
 387                 if (defined $_binarytosourcecache{$binname} and
 388                         exists $_binarytosourcecache{$binname}{$binver}) {
 389                         if (defined $binarch) {
 390                                 my $src = $_binarytosourcecache{$binname}{$binver}{$binarch};
 391                                 return () unless defined $src; # not on this arch
 392                                 # Copy the data to avoid tiedness problems.
 393                                 return [@$src];
 394                         } else {
 395                                 # Get (srcname, srcver) pairs for all architectures and
 396                                 # remove any duplicates. This involves some slightly tricky
 397                                 # multidimensional hashing; sorry. Fortunately there'll
 398                                 # usually only be one pair returned.
 399                                 my %uniq;
 400                                 for my $ar (keys %{$_binarytosourcecache{$binname}{$binver}}) {
 401                                         my $src = $_binarytosourcecache{$binname}{$binver}{$ar};
 402                                         next unless defined $src;
 403                                         $uniq{$src->[0]}{$src->[1]} = 1;
 404                                 }
 405                                 my @uniq;
 406                                 for my $sn (sort keys %uniq) {
 407                                         push @uniq, [$sn, $_] for sort keys %{$uniq{$sn}};
 408                                 }
 409                                 return @uniq;
 410                         }
 411                 }
 412     }
 413
 414     # No $gBinarySourceMap, or it didn't have an entry for this name and
 415     # version.
 416     return ();
 417 }
 418
 419 my %_versionobj;
 420 sub buggyversion {
 421     my ($bug, $ver, $status) = @_;
 422     return '' unless defined $versionpkgdir;
 423     my $src = getpkgsrc()->{$status->{package}};
 424     $src = $status->{package} unless defined $src;
 425
 426     my $tree;
 427     if (exists $_versionobj{$src}) {
 428         $tree = $_versionobj{$src};
 429     } else {
 430         $tree = Debbugs::Versions->new(\&DpkgVer::vercmp);
 431         my $srchash = substr $src, 0, 1;
 432         if (open VERFILE, "< $versionpkgdir/$srchash/$src") {
 433             $tree->load(\*VERFILE);
 434             close VERFILE;
 435         }
 436         $_versionobj{$src} = $tree;
 437     }
 438
 439     my @found = makesourceversions($status->{package}, undef,
 440                                    @{$status->{found_versions}});
 441     my @fixed = makesourceversions($status->{package}, undef,
 442                                    @{$status->{fixed_versions}});
 443
 444     return $tree->buggy($ver, \@found, \@fixed);
 445 }
 446
 447 sub getbugstatus {
 448     my ($bug,$common_version,$common_dist) = @_;
 449         my %status = %$bug;
 450
 451     my @versions;
 452     if (defined $common_version) {
 453         @versions = ($common_version);
 454     } elsif (defined $common_dist) {
 455         @versions = getversions($status{package}, $common_dist, $common_arch);
 456     }
 457
 458         if (not @versions) {
 459                 $status{"pending"} = 'absent';
 460                 return \%status;
 461         }
 462
 463     # TODO: This should probably be handled further out for efficiency and
 464     # for more ease of distinguishing between pkg= and src= queries.
 465     my @sourceversions = makesourceversions($status{package}, $common_arch,
 466                                             @versions);
 467
 468         $status{"pending"} = 'pending';
 469
 470     if (@sourceversions) {
 471         # Resolve bugginess states (we might be looking at multiple
 472         # architectures, say). Found wins, then fixed, then absent.
 473         my $maxbuggy = 'absent';
 474         for my $version (@sourceversions) {
 475             my $buggy = buggyversion($bugnum, $version, \%status);
 476             if ($buggy eq 'found') {
 477                 $maxbuggy = 'found';
 478                 last;
 479             } elsif ($buggy eq 'fixed' and $maxbuggy ne 'found') {
 480                 $maxbuggy = 'fixed';
 481             }
 482         }
 483         if ($maxbuggy eq 'absent') {
 484             $status{"pending"} = 'absent';
 485         } elsif ($maxbuggy eq 'fixed') {
 486             $status{"pending"} = 'done';
 487         }
 488     }
 489
 490     if (length($status{done}) and
 491             (not @sourceversions or not @{$status{fixed_versions}})) {
 492         $status{"pending"} = 'done';
 493     }
 494
 495     return \%status;
 496 }
 497
 498 my %_versions;
 499 my %_binversioncache = ();
 500 sub getversions {
 501     my ($pkg, $dist, $arch) = @_;
 502     return () unless defined $versionindex;
 503     $dist = 'unstable' unless defined $dist;
 504
 505     unless (tied %_versions) {
 506         tie %_versions, 'MLDBM', $versionindex, O_RDONLY
 507             or die "can't open versions index: $!";
 508     }
 509
 510         if (!exists($_binversioncache{$pkg})) {
 511                 $_binversioncache{$pkg} = \%{ $_versions{$pkg} };
 512         }
 513         #if ($pkg eq 'atlas3-base') {
 514         #       require Data::Dumper;
 515         #       print STDERR Data::Dumper::Dumper($_versions{$pkg});
 516         #}
 517
 518         if (defined $arch and exists $_binversioncache{$pkg}{$dist}{$arch}) {
 519                 my $ver = $_binversioncache{$pkg}{$dist}{$arch};
 520                 if (defined($ver)) {
 521                         return $ver;
 522                 } else {
 523                         return ();
 524                 }
 525         } else {
 526                 my %uniq;
 527                 for my $ar (keys %{$_binversioncache{$pkg}{$dist}}) {
 528                         $uniq{$_binversioncache{$pkg}{$dist}{$ar}} = 1 unless ($ar eq 'source' or $ar eq 'm68k' or $ar eq 'hurd-i386');
 529                 }
 530                 if (%uniq) {
 531                         return keys %uniq;
 532                 } elsif (exists $_binversioncache{$pkg}{$dist}{source}) {
 533                         # Maybe this is actually a source package with no corresponding
 534                         # binaries?
 535                         return $_binversioncache{$pkg}{$dist}{source};
 536                 } else {
 537                         return ();
 538                 }
 539         }
 540 }
 541
 542 my %_sourceversioncache = ();
 543 sub makesourceversions {
 544     my $pkg = shift;
 545     my $arch = shift;
 546     my %sourceversions;
 547
 548     for my $version (@_) {
 549         if ($version =~ m[/]) {
 550             # Already a source version.
 551             $sourceversions{$version} = 1;
 552         } else {
 553             my $cachearch = (defined $arch) ? $arch : '';
 554             my $cachekey = "$pkg/$cachearch/$version";
 555             if (exists($_sourceversioncache{$cachekey})) {
 556                 for my $v (@{$_sourceversioncache{$cachekey}}) {
 557                                         $sourceversions{$v} = 1;
 558                                 }
 559                                 next;
 560                         }
 561
 562                         my @srcinfo = binarytosource($pkg, $version, $arch);
 563                         unless (@srcinfo) {
 564                                 # We don't have explicit information about the
 565                                 # binary-to-source mapping for this version (yet). Since
 566                                 # this is a CGI script and our output is transient, we can
 567                                 # get away with just looking in the unversioned map; if it's
 568                                 # wrong (as it will be when binary and source package
 569                                 # versions differ), too bad.
 570                                 my $pkgsrc = getpkgsrc();
 571                                 if (exists $pkgsrc->{$pkg}) {
 572                                         @srcinfo = ([$pkgsrc->{$pkg}, $version]);
 573                                 } elsif (getsrcpkgs($pkg)) {
 574                                         # If we're looking at a source package that doesn't have
 575                                         # a binary of the same name, just try the same version.
 576                                         @srcinfo = ([$pkg, $version]);
 577                                 } else {
 578                                         next;
 579                                 }
 580                         }
 581                         $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo;
 582                         $_sourceversioncache{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ];
 583                 }
 584         }
 585
 586     return sort keys %sourceversions;
 587 }
 588
 589 my %fields = (originator => 'submitter',
 590               date => 'date',
 591               subject => 'subject',
 592               msgid => 'message-id',
 593               'package' => 'package',
 594               keywords => 'tags',
 595               done => 'done',
 596               forwarded => 'forwarded-to',
 597               mergedwith => 'merged-with',
 598               severity => 'severity',
 599               owner => 'owner',
 600               found_versions => 'found-in',
 601               fixed_versions => 'fixed-in',
 602               blocks => 'blocks',
 603               blockedby => 'blocked-by',
 604              );
 605
 606 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
 607 my @rfc1522_fields = qw(originator subject done forwarded owner);
 608
 609 sub readbug {
 610     my ($location) = @_;
 611     if (!open(S,$location)) { return undef; }
 612
 613     my %data;
 614     my @lines;
 615     my $version = 2;
 616     local $_;
 617
 618     while (<S>) {
 619         chomp;
 620         push @lines, $_;
 621         $version = $1 if /^Format-Version: ([0-9]+)/i;
 622     }
 623
 624     # Version 3 is the latest format version currently supported.
 625     return undef if $version > 3;
 626
 627     my %namemap = reverse %fields;
 628     for my $line (@lines) {
 629         if ($line =~ /(\S+?): (.*)/) {
 630             my ($name, $value) = (lc $1, $2);
 631             $data{$namemap{$name}} = $value if exists $namemap{$name};
 632         }
 633     }
 634     for my $field (keys %fields) {
 635         $data{$field} = '' unless exists $data{$field};
 636     }
 637
 638     close(S);
 639
 640     $data{severity} = $gDefaultSeverity if $data{severity} eq '';
 641     $data{found_versions} = [split ' ', $data{found_versions}];
 642     $data{fixed_versions} = [split ' ', $data{fixed_versions}];
 643
 644     if ($version < 3) {
 645                 for my $field (@rfc1522_fields) {
 646                         $data{$field} = decode_rfc1522($data{$field});
 647                 }
 648     }
 649
 650     return \%data;
 651 }
 652
 653 sub check_worry {
 654     my ($status) = @_;
 655
 656     if ($status =~ m/^\[[^]]*I/ or
 657         $status =~ m/ \[[^]]*X/ or
 658         ($status =~ m/ \[[^]]*[OSUE]/ and $status !~ m/ \[[^]]*T/)) {
 659         return 0;
 660     }
 661     return 1;
 662 }