lib/CPAN/Testers/ParseReport.pm

   1 package CPAN::Testers::ParseReport;
   2
   3 use warnings;
   4 use strict;
   5
   6 use DateTime::Format::Strptime;
   7 use File::Basename qw(basename);
   8 use File::Path qw(mkpath);
   9 use HTML::Entities qw(decode_entities);
  10 use LWP::UserAgent;
  11 use List::Util qw(max sum);
  12 use XML::LibXML;
  13 use XML::LibXML::XPathContext;
  14
  15 our $default_ctformat = "html";
  16 our $default_cturl = "http://www.cpantesters.org/show";
  17 our $Signal = 0;
  18
  19 =encoding utf-8
  20
  21 =head1 NAME
  22
  23 CPAN::Testers::ParseReport - parse reports to www.cpantesters.org from various sources
  24
  25 =cut
  26
  27 use version; our $VERSION = qv('0.0.13');
  28
  29 =head1 SYNOPSIS
  30
  31 The documentation in here is normally not needed because the code is
  32 meant to be run from a standalone program, L<ctgetreports>.
  33
  34   ctgetreports --q mod:Moose Devel-Events
  35
  36 =head1 DESCRIPTION
  37
  38 This is the core module for CPAN::Testers::ParseReport. If you're not
  39 looking to extend or alter the behaviour of this module, you probably
  40 want to look at L<ctgetreports> instead.
  41
  42 =head1 OPTIONS
  43
  44 Are described in the L<ctgetreports> manpage and are passed through to
  45 the functions unaltered.
  46
  47 =head1 FUNCTIONS
  48
  49 =head2 parse_distro($distro,$options)
  50
  51 reads the cpantesters HTML page or the YAML file for the distro and
  52 loops through the reports for the specified or most recent version of
  53 that distro found in these data.
  54
  55 =head2 parse_single_report($report,$dumpvars,$options)
  56
  57 mirrors and reads this report. $report is of the for
  58
  59   { id => number }
  60
  61 $dumpvar is a hashreference that gets filled with data.
  62
  63 =cut
  64
  65 {
  66     my $ua;
  67     sub _ua {
  68         return $ua if $ua;
  69         $ua = LWP::UserAgent->new
  70             (
  71              keep_alive => 1,
  72             );
  73         $ua->parse_head(0);
  74         $ua;
  75     }
  76 }
  77
  78 {
  79     my $xp;
  80     sub _xp {
  81         return $xp if $xp;
  82         $xp = XML::LibXML->new;
  83         $xp->keep_blanks(0);
  84         $xp->clean_namespaces(1);
  85         my $catalog = __FILE__;
  86         $catalog =~ s|ParseReport.pm$|ParseReport/catalog|;
  87         $xp->load_catalog($catalog);
  88         return $xp;
  89     }
  90 }
  91
  92 sub _download_overview {
  93     my($cts_dir, $distro, %Opt) = @_;
  94     my $format = $Opt{ctformat} ||= $default_ctformat;
  95     my $cturl = $Opt{cturl} ||= $default_cturl;
  96     my $ctarget = "$cts_dir/$distro.$format";
  97     my $cheaders = "$cts_dir/$distro.headers";
  98     if ($Opt{local}) {
  99         unless (-e $ctarget) {
 100             die "Alert: No local file '$ctarget' found, cannot continue\n";
 101         }
 102     } else {
 103         if (! -e $ctarget or -M $ctarget > .25) {
 104             if (-e $ctarget && $Opt{verbose}) {
 105                 my(@stat) = stat _;
 106                 my $timestamp = gmtime $stat[9];
 107                 print STDERR "(timestamp $timestamp GMT)\n" unless $Opt{quiet};
 108             }
 109             print STDERR "Fetching $ctarget..." if $Opt{verbose} && !$Opt{quiet};
 110             my $uri = "$cturl/$distro.$format";
 111             my $resp = _ua->mirror($uri,$ctarget);
 112             if ($resp->is_success) {
 113                 print STDERR "DONE\n" if $Opt{verbose} && !$Opt{quiet};
 114                 open my $fh, ">", $cheaders or die;
 115                 for ($resp->headers->as_string) {
 116                     print $fh $_;
 117                     if ($Opt{verbose} && $Opt{verbose}>1) {
 118                         print STDERR $_ unless $Opt{quiet};
 119                     }
 120                 }
 121             } elsif (304 == $resp->code) {
 122                 print STDERR "DONE (not modified)\n" if $Opt{verbose} && !$Opt{quiet};
 123                 my $atime = my $mtime = time;
 124                 utime $atime, $mtime, $cheaders;
 125             } else {
 126                 die sprintf
 127                     (
 128                      "No success downloading %s: %s",
 129                      $uri,
 130                      $resp->status_line,
 131                     );
 132             }
 133         }
 134     }
 135     return $ctarget;
 136 }
 137
 138 sub _parse_html {
 139     my($ctarget, %Opt) = @_;
 140     my $content = do { open my $fh, $ctarget or die; local $/; <$fh> };
 141     my $preprocesswithtreebuilder = 0; # not needed since barbie switched to XHTML
 142     if ($preprocesswithtreebuilder) {
 143         require HTML::TreeBuilder;
 144         my $tree = HTML::TreeBuilder->new;
 145         $tree->implicit_tags(1);
 146         $tree->p_strict(1);
 147         $tree->ignore_ignorable_whitespace(0);
 148         $tree->parse_content($content);
 149         $tree->eof;
 150         $content = $tree->as_XML;
 151     }
 152     my $parser = _xp();
 153     my $doc = eval { $parser->parse_string($content) };
 154     my $err = $@;
 155     unless ($doc) {
 156         my $distro = basename $ctarget;
 157         die sprintf "Error while parsing %s\: %s", $distro, $err;
 158     }
 159     my $xc = XML::LibXML::XPathContext->new($doc);
 160     my $nsu = $doc->documentElement->namespaceURI;
 161     $xc->registerNs('x', $nsu) if $nsu;
 162     my($selected_release_ul,$selected_release_distrov,$excuse_string);
 163     my($cparentdiv)
 164         = $nsu ?
 165             $xc->findnodes("/x:html/x:body/x:div[\@id = 'doc']") :
 166                 $doc->findnodes("/html/body/div[\@id = 'doc']");
 167     my(@releasedivs) = $nsu ?
 168         $xc->findnodes("//x:div[x:h2 and x:ul]",$cparentdiv) :
 169             $cparentdiv->findnodes("//div[h2 and ul]");
 170     my $releasediv;
 171     if ($Opt{vdistro}) {
 172         $excuse_string = "selected distro '$Opt{vdistro}'";
 173         my($fallbacktoversion) = $Opt{vdistro} =~ /(\d+\..*)/;
 174       RELEASE: for my $i (0..$#releasedivs) {
 175             my $picked = "";
 176             my($x) = $nsu ?
 177                 $xc->findvalue("x:h2/x:a[2]/\@name",$releasedivs[$i]) :
 178                     $releasedivs[$i]->findvalue("h2/a[2]/\@name");
 179             $DB::single=1;
 180             if ($x) {
 181                 if ($x eq $Opt{vdistro}) {
 182                     $releasediv = $i;
 183                     $picked = " (picked)";
 184                 }
 185                 print STDERR "FOUND DISTRO: $x$picked\n" unless $Opt{quiet};
 186             } else {
 187                 ($x) = $nsu ?
 188                     $xc->findvalue("x:h2/x:a[1]/\@name",$releasedivs[$i]) :
 189                         $releasedivs[$i]->findvalue("h2/a[1]/\@name");
 190                 if ($x eq $fallbacktoversion) {
 191                     $releasediv = $i;
 192                     $picked = " (picked)";
 193                 }
 194                 print STDERR "FOUND VERSION: $x$picked\n" unless $Opt{quiet};
 195             }
 196         }
 197     } else {
 198         $excuse_string = "any distro";
 199     }
 200     unless (defined $releasediv) {
 201         $releasediv = 0;
 202     }
 203     $DB::single=1;
 204     # using a[1] because a[2] is missing on the first entry
 205     ($selected_release_distrov) = $nsu ?
 206         $xc->findvalue("x:h2/x:a[1]/\@name",$releasedivs[$releasediv]) :
 207             $releasedivs[$releasediv]->findvalue("h2/a[1]/\@name");
 208     ($selected_release_ul) = $nsu ?
 209         $xc->findnodes("x:ul",$releasedivs[$releasediv]) :
 210             $releasedivs[$releasediv]->findnodes("ul");
 211     unless (defined $selected_release_distrov) {
 212         warn "Warning: could not find $excuse_string in '$ctarget'";
 213         return;
 214     }
 215     print STDERR "SELECTED: $selected_release_distrov\n" unless $Opt{quiet};
 216     my($id);
 217     my @all;
 218     for my $test ($nsu ?
 219                   $xc->findnodes("x:li",$selected_release_ul) :
 220                   $selected_release_ul->findnodes("li")) {
 221         $id = $nsu ?
 222             $xc->findvalue("x:a[1]/text()",$test)     :
 223                 $test->findvalue("a[1]/text()");
 224         push @all, {id=>$id};
 225         return if $Signal;
 226     }
 227     return \@all;
 228 }
 229
 230 sub _parse_yaml {
 231     my($ctarget, %Opt) = @_;
 232     require YAML::Syck;
 233     my $arr = YAML::Syck::LoadFile($ctarget);
 234     my($selected_release_ul,$selected_release_distrov,$excuse_string);
 235     if ($Opt{vdistro}) {
 236         $excuse_string = "selected distro '$Opt{vdistro}'";
 237         $arr = [grep {$_->{distversion} eq $Opt{vdistro}} @$arr];
 238         ($selected_release_distrov) = $arr->[0]{distversion};
 239     } else {
 240         $excuse_string = "any distro";
 241         my $last_addition;
 242         my %seen;
 243         for my $report (@$arr) {
 244             unless ($seen{$report->{distversion}}++) {
 245                 $last_addition = $report->{distversion};
 246             }
 247         }
 248         $arr = [grep {$_->{distversion} eq $last_addition} @$arr];
 249         ($selected_release_distrov) = $last_addition;
 250     }
 251     unless ($selected_release_distrov) {
 252         warn "Warning: could not find $excuse_string in '$ctarget'";
 253         return;
 254     }
 255     print STDERR "SELECTED: $selected_release_distrov\n" unless $Opt{quiet};
 256     my @all;
 257     for my $test (@$arr) {
 258         my $id = $test->{id};
 259         push @all, {id=>$id};
 260         return if $Signal;
 261     }
 262     @all = sort { $b->{id} <=> $a->{id} } @all;
 263     return \@all;
 264 }
 265
 266 sub parse_single_report {
 267     my($report, $dumpvars, %Opt) = @_;
 268     my($id) = $report->{id};
 269     $Opt{cachedir} ||= "$ENV{HOME}/var/cpantesters";
 270     my $nnt_dir = "$Opt{cachedir}/nntp-testers";
 271     mkpath $nnt_dir;
 272     my $target = "$nnt_dir/$id";
 273     if ($Opt{local}) {
 274         unless (-e $target) {
 275             warn "Warning: No local file '$target' found, skipping\n";
 276             return;
 277         }
 278     } else {
 279         if (! -e $target) {
 280             print STDERR "Fetching $target..." if $Opt{verbose} && !$Opt{quiet};
 281             my $resp = _ua->mirror("http://www.nntp.perl.org/group/perl.cpan.testers/$id",$target);
 282             if ($resp->is_success) {
 283                 if ($Opt{verbose}) {
 284                     my(@stat) = stat $target;
 285                     my $timestamp = gmtime $stat[9];
 286                     print STDERR "(timestamp $timestamp GMT)\n" unless $Opt{quiet};
 287                     if ($Opt{verbose} > 1) {
 288                         print STDERR $resp->headers->as_string unless $Opt{quiet};
 289                     }
 290                 }
 291                 my $headers = "$target.headers";
 292                 open my $fh, ">", $headers or die;
 293                 print $fh $resp->headers->as_string;
 294             } else {
 295                 die $resp->status_line;
 296             }
 297         }
 298     }
 299     parse_report($target, $dumpvars, %Opt);
 300 }
 301
 302 sub parse_distro {
 303     my($distro,%Opt) = @_;
 304     my %dumpvars;
 305     $Opt{cachedir} ||= "$ENV{HOME}/var/cpantesters";
 306     my $cts_dir = "$Opt{cachedir}/cpantesters-show";
 307     mkpath $cts_dir;
 308     if ($Opt{solve}) {
 309         require Statistics::Regression;
 310         $Opt{dumpvars} = "." unless defined $Opt{dumpvars};
 311         $Opt{quiet} = 1 unless defined $Opt{quiet};
 312     }
 313     my $ctarget = _download_overview($cts_dir, $distro, %Opt);
 314     my $reports;
 315     $Opt{ctformat} ||= $default_ctformat;
 316     if ($Opt{ctformat} eq "html") {
 317         $reports = _parse_html($ctarget,%Opt);
 318     } else {
 319         $reports = _parse_yaml($ctarget,%Opt);
 320     }
 321     return unless $reports;
 322     for my $report (@$reports) {
 323         parse_single_report($report, \%dumpvars, %Opt);
 324         last if $Signal;
 325     }
 326     if ($Opt{dumpvars}) {
 327         require YAML::Syck;
 328         my $dumpfile = $Opt{dumpfile} || "ctgetreports.out";
 329         open my $fh, ">", $dumpfile or die "Could not open '$dumpfile' for writing: $!";
 330         print $fh YAML::Syck::Dump(\%dumpvars);
 331         close $fh or die "Could not close '$dumpfile': $!"
 332     }
 333     if ($Opt{solve}) {
 334         solve(\%dumpvars);
 335     }
 336 }
 337
 338 =head2 parse_report($target,$dumpvars,%Opt)
 339
 340 Reads one report. $target is the local filename to read. $dumpvars is
 341 a hashref which gets filled. %Opt are the options as described in the
 342 C<ctgetreports> manpage.
 343
 344 Note: this parsing is a bit dirty but as it seems good enough I'm not
 345 inclined to change it. We parse HTML with a regexps only, no HTML
 346 parser working, only the entities are decoded.
 347
 348 =cut
 349 sub parse_report {
 350     my($target,$dumpvars,%Opt) = @_;
 351     our @q;
 352     my $id = basename($target);
 353     my($ok,$about);
 354
 355     my(%extract);
 356
 357     my $report;
 358     my @qr = map /^qr:(.+)/, @{$Opt{q}};
 359     if ($Opt{raw} || @qr) {
 360         open my $fh, $target or die "Could not open '$target': $!";
 361         local $/;
 362         $report = decode_entities <$fh>;
 363         close $fh;
 364         for my $qr (@qr) {
 365             my $cqr = eval "qr{$qr}";
 366             die "Could not compile regular expression '$qr': $@" if $@;
 367             my(@matches) = $report =~ $cqr;
 368             my $v;
 369             if (@matches) {
 370                 if (@matches==1) {
 371                     $v = $matches[0];
 372                 } else {
 373                     $v = join "", map {"($_)"} @matches;
 374                 }
 375             } else {
 376                 $v = "";
 377             }
 378             $extract{"qr:$qr"} = $v;
 379         }
 380     }
 381
 382     open my $fh, $target or die "Could not open '$target': $!";
 383
 384     my $report_writer;
 385     my $moduleunpack = {};
 386     my $expect_prereq = 0;
 387     my $expect_toolchain = 0;
 388     my $expecting_toolchain_soon = 0;
 389
 390     my $in_summary = 0;
 391     my $in_prg_output = 0;
 392     my $in_env_context = 0;
 393
 394     my $current_headline;
 395     my @previous_line = ""; # so we can neutralize line breaks
 396   LINE: while (<$fh>) {
 397         next unless /<title>(\S+)\s+(\S+)/;
 398         $ok = $1;
 399         $about = $2;
 400         $extract{"meta:ok"}    = $ok;
 401         $extract{"meta:about"} = $about;
 402         last;
 403     }
 404     seek $fh, 0, 0;
 405   LINE: while (<$fh>) {
 406         s/\r?\n\z//;
 407         while (/!$/) {
 408             my $followupline = <$fh>;
 409             $followupline =~ s/^\s+//; # remo leading space
 410             $_ .= $followupline;
 411             s/\r?\n\z//;
 412         }
 413         $_ = decode_entities $_;
 414         if (/^--------/ && $previous_line[-2] && $previous_line[-2] =~ /^--------/) {
 415             $current_headline = $previous_line[-1];
 416             if ($current_headline =~ /PROGRAM OUTPUT/) {
 417                 $in_prg_output = 1;
 418             } else {
 419                 $in_prg_output = 0;
 420             }
 421             if ($current_headline =~ /ENVIRONMENT AND OTHER CONTEXT/) {
 422                 $in_env_context = 1;
 423             } else {
 424                 $in_env_context = 0;
 425             }
 426         }
 427         unless ($extract{"meta:perl"}) {
 428             my $p5;
 429             if (0) {
 430             } elsif (/Summary of my perl5 \((.+)\) configuration:/) {
 431                 $p5 = $1;
 432                 $in_summary = 1;
 433                 $in_env_context = 0;
 434             }
 435             if ($p5) {
 436                 my($r,$v,$s,$p);
 437                 if (($r,$v,$s,$p) = $p5 =~ /revision (\S+) version (\S+) subversion (\S+) patch (\S+)/) {
 438                     $r =~ s/\.0//; # 5.0 6 2!
 439                     $extract{"meta:perl"} = "$r.$v.$s\@$p";
 440                 } elsif (($r,$v,$s) = $p5 =~ /revision (\S+) version (\S+) subversion (\S+)/) {
 441                     $r =~ s/\.0//;
 442                     $extract{"meta:perl"} = "$r.$v.$s";
 443                 } elsif (($r,$v,$s) = $p5 =~ /(\d+\S*) patchlevel (\S+) subversion (\S+)/) {
 444                     $r =~ s/\.0//;
 445                     $extract{"meta:perl"} = "$r.$v.$s";
 446                 } else {
 447                     $extract{"meta:perl"} = $p5;
 448                 }
 449             }
 450         }
 451         unless ($extract{"meta:from"}) {
 452             if (0) {
 453             } elsif (m|<div class="h_name">From:</div> <b>(.+?)</b><br/>|) {
 454                 $extract{"meta:from"} = $1;
 455             }
 456             $extract{"meta:from"} =~ s/\.$// if $extract{"meta:from"};
 457         }
 458         unless ($extract{"meta:date"}) {
 459             if (0) {
 460             } elsif (m|<div class="h_name">Date:</div> (.+?)<br/>|) {
 461                 my $date = $1;
 462                 my $p = DateTime::Format::Strptime->new(
 463                                                         locale => "en",
 464                                                         time_zone => "UTC",
 465                                                         # April 13, 2005 23:50
 466                                                         pattern => "%b %d, %Y %R",
 467                                                        );
 468                 my $dt = $p->parse_datetime($date);
 469                 $extract{"meta:date"} = $dt->datetime;
 470             }
 471             $extract{"meta:date"} =~ s/\.$// if $extract{"meta:date"};
 472         }
 473         unless ($extract{"meta:writer"}) {
 474             for ("$previous_line[-1] $_") {
 475                 if (0) {
 476                 } elsif (/created (?:automatically )?by (\S+)/) {
 477                     $extract{"meta:writer"} = $1;
 478                 } elsif (/CPANPLUS, version (\S+)/) {
 479                     $extract{"meta:writer"} = "CPANPLUS $1";
 480                 } elsif (/This report was machine-generated by (\S+) (\S+)/) {
 481                     $extract{"meta:writer"} = "$1 $2";
 482                 }
 483                 $extract{"meta:writer"} =~ s/[\.,]$// if $extract{"meta:writer"};
 484             }
 485         }
 486         if ($in_summary) {
 487             # we do that first three lines a bit too often
 488             my $qr = $Opt{dumpvars} || "";
 489             $qr = qr/$qr/ if $qr;
 490             unless (@q) {
 491                 @q = @{$Opt{q}||[]};
 492                 @q = qw(meta:perl conf:archname conf:usethreads conf:optimize meta:writer meta:from) unless @q;
 493             }
 494
 495             my %conf_vars = map {($_ => 1)} grep { /^conf:/ } @q;
 496
 497             if (/^\s*$/ || m|</pre>|) {
 498                 $in_summary = 0;
 499             } else {
 500                 my(%kv) = /\G,?\s*([^=]+)=('[^']+?'|\S+)/gc;
 501                 while (my($k,$v) = each %kv) {
 502                     my $ck = "conf:$k";
 503                     $v =~ s/,$//;
 504                     if ($v =~ /^'(.*)'$/) {
 505                         $v = $1;
 506                     }
 507                     $v =~ s/^\s+//;
 508                     $v =~ s/\s+$//;
 509                     if ($qr && $ck =~ $qr) {
 510                         $dumpvars->{$ck}{$v}{$ok}++;
 511                         $extract{$ck} = $v;
 512                     } elsif ($conf_vars{$ck}) {
 513                         $extract{$ck} = $v;
 514                     }
 515                 }
 516             }
 517         }
 518         if ($in_prg_output) {
 519             unless ($extract{"meta:output_from"}) {
 520                 if (/Output from (.+):$/) {
 521                     $extract{"meta:output_from"} = $1
 522                 }
 523             }
 524         }
 525         if ($in_env_context) {
 526             if (/^\s{4}(\S+)\s*=\s*(.*)$/) {
 527                 $extract{"env:$1"} = $2;
 528             }
 529         }
 530         push @previous_line, $_;
 531         if ($expect_prereq || $expect_toolchain) {
 532             if (exists $moduleunpack->{type}) {
 533                 my($module,$v);
 534                 if ($moduleunpack->{type} == 1) {
 535                     (my $leader,$module,undef,$v) = eval { unpack $moduleunpack->{tpl}, $_; };
 536                     next LINE if $@;
 537                     if ($leader =~ /^-/) {
 538                         $moduleunpack = {};
 539                         $expect_prereq = 0;
 540                         next LINE;
 541                     } elsif ($leader =~ /^(
 542                                          buil          # build_requires:
 543                                         )/x) {
 544                         next LINE;
 545                     } elsif ($module =~ /^(
 546                                          -             # line drawing
 547                                         )/x) {
 548                         next LINE;
 549                     }
 550                 } elsif ($moduleunpack->{type} == 2) {
 551                     (my $leader,$module,$v) = eval { unpack $moduleunpack->{tpl}, $_; };
 552                     next LINE if $@;
 553                     if ($leader =~ /^\*/) {
 554                         $moduleunpack = {};
 555                         $expect_prereq = 0;
 556                         next LINE;
 557                     }
 558                 } elsif ($moduleunpack->{type} == 3) {
 559                     (my $leader,$module,$v) = eval { unpack $moduleunpack->{tpl}, $_; };
 560                     next LINE if $@;
 561                     if (!$module) {
 562                         $moduleunpack = {};
 563                         $expect_toolchain = 0;
 564                         next LINE;
 565                     } elsif ($module =~ /^-/) {
 566                         next LINE;
 567                     }
 568                 }
 569                 $module =~ s/\s+$//;
 570                 if ($module) {
 571                     $v =~ s/^\s+//;
 572                     $v =~ s/\s+$//;
 573                     $extract{"mod:$module"} = $v;
 574                 }
 575             }
 576             if (/(\s+)(Module\s+)(Need\s+)Have/) {
 577                 $in_env_context = 0;
 578                 $moduleunpack = {
 579                                  tpl => 'a'.length($1).'a'.length($2).'a'.length($3).'a*',
 580                                  type => 1,
 581                                 };
 582             } elsif (/(\s+)(Module Name\s+)(Have)(\s+)Want/) {
 583                 $in_env_context = 0;
 584                 my $adjust_1 = 0;
 585                 my $adjust_2 = -length($4);
 586                 my $adjust_3 = length($4);
 587                 # two pass would be required to see where the
 588                 # columns really are. Or could we get away with split?
 589                 $moduleunpack = {
 590                                  tpl => 'a'.length($1).'a'.(length($2)+$adjust_2).'a'.(length($3)+$adjust_3),
 591                                  type => 2,
 592                                 };
 593             }
 594         }
 595         if (/PREREQUISITES|Prerequisite modules loaded/) {
 596             $in_env_context = 0;
 597             $expect_prereq=1;
 598         }
 599         if ($expecting_toolchain_soon) {
 600             if (/(\s+)(Module\s+) Have/) {
 601                 $in_env_context = 0;
 602                 $expect_toolchain=1;
 603                 $expecting_toolchain_soon=0;
 604                 $moduleunpack = {
 605                                  tpl => 'a'.length($1).'a'.length($2).'a*',
 606                                  type => 3,
 607                                 };
 608             }
 609         }
 610         if (/toolchain versions installed/) {
 611             $in_env_context = 0;
 612             $expecting_toolchain_soon=1;
 613         }
 614     }                           # LINE
 615     my $diag = "";
 616     if (my $qr = $Opt{dumpvars}) {
 617         $qr = qr/$qr/;
 618         while (my($k,$v) = each %extract) {
 619             if ($k =~ $qr) {
 620                 $dumpvars->{$k}{$v}{$ok}++;
 621             }
 622         }
 623     }
 624     for my $want (@q) {
 625         my $have  = $extract{$want} || "";
 626         $diag .= " $want\[$have]";
 627     }
 628     if ($Opt{solve}) {
 629         $extract{id} = $id;
 630         my $data = $dumpvars->{"==DATA=="} ||= [];
 631         push @$data, \%extract;
 632     }
 633     printf STDERR " %-4s %8d%s\n", $ok, $id, $diag unless $Opt{quiet};
 634     if ($Opt{raw}) {
 635         $report =~ s/\s+\z//;
 636         print STDERR $report, "\n================\n" unless $Opt{quiet};
 637     }
 638     if ($Opt{interactive}) {
 639         require IO::Prompt;
 640         local @ARGV;
 641         local $ARGV;
 642         my $ans = IO::Prompt::prompt
 643             (
 644              -p => "View $id? [onechar: ynq] ",
 645              -d => "y",
 646              -u => qr/[ynq]/,
 647              -onechar,
 648             );
 649         print STDERR "\n" unless $Opt{quiet};
 650         if ($ans eq "y") {
 651             open my $ifh, "<", $target or die "Could not open $target: $!";
 652             $Opt{pager} ||= "less";
 653             open my $lfh, "|-", $Opt{pager} or die "Could not fork '$Opt{pager}': $!";
 654             local $/;
 655             print {$lfh} <$ifh>;
 656             close $ifh or die "Could not close $target: $!";
 657             close $lfh or die "Could not close pager: $!"
 658         } elsif ($ans eq "q") {
 659             $Signal++;
 660             return;
 661         }
 662     }
 663 }
 664
 665 =head2 solve
 666
 667 (TBD)
 668
 669 =cut
 670
 671 sub solve {
 672     my($V) = @_;
 673     require Statistics::Regression;
 674     my @regression;
 675     for my $variable (sort keys %$V) {
 676         next if $variable eq "==DATA==";
 677         my $value_distribution = $V->{$variable};
 678         my $keys = keys %$value_distribution;
 679         my @results;
 680         my @X = qw(const);
 681         for my $value (sort keys %$value_distribution) {
 682             my $pf = $value_distribution->{$value};
 683             $pf->{PASS} ||= 0;
 684             $pf->{FAIL} ||= 0;
 685             my $provers = sum map {$pf->{$_}} qw(PASS FAIL);
 686             push @results, $provers;
 687             push @X, "eq_$value";
 688             if (
 689                 $pf->{PASS} xor $pf->{FAIL}
 690                ) {
 691                 my $vl = 40;
 692                 substr($value,$vl) = "..." if length $value > 3+$vl;
 693                 my $poor_mans_freehand_estimation = 0;
 694                 if ($poor_mans_freehand_estimation) {
 695                     warn sprintf
 696                         (
 697                          "%4d %4d %-23s | %s\n",
 698                          $pf->{PASS},
 699                          $pf->{FAIL},
 700                          $variable,
 701                          $value,
 702                         );
 703                 }
 704             }
 705         }
 706         my $results = max @results;
 707         if ($results > 1){
 708             warn "variable[$variable]keys[$keys]results[$results]\n";
 709             my $reg = Statistics::Regression->new("reg_$variable",\@X);
 710           RECORD: for my $rec (@{$V->{"==DATA=="}}) {
 711                 my $y;
 712                 if ($rec->{"meta:ok"} eq "PASS") {
 713                     $y = 1;
 714                 } elsif ($rec->{"meta:ok"} eq "FAIL") {
 715                     $y = 0;
 716                 } else {
 717                     next RECORD;
 718                 }
 719                 my %obs;
 720                 @obs{@X} = (0) x @X;
 721                 $obs{const} = 1;
 722                 for my $x (@X) {
 723                     next unless $x =~ /^eq_(.+)/;
 724                     my $v = $1;
 725                     if (exists $rec->{$variable} && defined $rec->{$variable} && $rec->{$variable} eq $v) {
 726                         $obs{$x} = 1;
 727                     }
 728                 }
 729                 $reg->include($y, \%obs);
 730             }
 731             $reg->print;
 732         } else {
 733             # irrelevant observation or something that needs further
 734             # tweaking, like date
 735         }
 736     }
 737     die "FIXME";
 738 }
 739
 740 =head1 AUTHOR
 741
 742 Andreas König
 743
 744 =head1 BUGS
 745
 746 Please report any bugs or feature requests through the web
 747 interface at
 748 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Testers-ParseReport>.
 749 I will be notified, and then you'll automatically be notified of
 750 progress on your bug as I make changes.
 751
 752 =head1 SUPPORT
 753
 754 You can find documentation for this module with the perldoc command.
 755
 756     perldoc CPAN::Testers::ParseReport
 757
 758
 759 You can also look for information at:
 760
 761 =over 4
 762
 763 =item * RT: CPAN's request tracker
 764
 765 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CPAN-Testers-ParseReport>
 766
 767 =item * AnnoCPAN: Annotated CPAN documentation
 768
 769 L<http://annocpan.org/dist/CPAN-Testers-ParseReport>
 770
 771 =item * CPAN Ratings
 772
 773 L<http://cpanratings.perl.org/d/CPAN-Testers-ParseReport>
 774
 775 =item * Search CPAN
 776
 777 L<http://search.cpan.org/dist/CPAN-Testers-ParseReport>
 778
 779 =back
 780
 781
 782 =head1 ACKNOWLEDGEMENTS
 783
 784 Thanks to RJBS for module-starter.
 785
 786 =head1 COPYRIGHT & LICENSE
 787
 788 Copyright 2008 Andreas König.
 789
 790 This program is free software; you can redistribute it and/or modify it
 791 under the same terms as Perl itself.
 792
 793
 794 =cut
 795
 796 1; # End of CPAN::Testers::ParseReport