1# Copyright 2001-2019, Paul Johnson (paul@pjcj.net) 2 3# This software is free. It is licensed under the same terms as Perl itself. 4 5# The latest version of this software should be available from my homepage: 6# http://www.pjcj.net 7 8package Devel::Cover; 9 10use strict; 11use warnings; 12 13our $VERSION; 14BEGIN { 15our $VERSION = '1.36'; # VERSION 16} 17 18use DynaLoader (); 19our @ISA = "DynaLoader"; 20 21use Devel::Cover::DB; 22use Devel::Cover::DB::Digests; 23use Devel::Cover::Inc; 24 25BEGIN { $VERSION //= $Devel::Cover::Inc::VERSION } 26 27use B qw( ppname main_cv main_start main_root walksymtable OPf_KIDS ); 28use B::Debug; 29use B::Deparse; 30 31use Carp; 32use Config; 33use Cwd qw( abs_path getcwd ); 34use File::Spec; 35 36use Devel::Cover::Dumper; 37use Devel::Cover::Util "remove_contained_paths"; 38 39BEGIN { 40 # Use Pod::Coverage if it is available 41 eval "use Pod::Coverage 0.06"; 42 # If there is any error other than a failure to locate, report it 43 die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; 44 45 # We'll prefer Pod::Coverage::CountParents 46 eval "use Pod::Coverage::CountParents"; 47 die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; 48} 49 50# $SIG{__DIE__} = \&Carp::confess; 51# sub Pod::Coverage::TRACE_ALL () { 1 } 52 53my $Initialised; # import() has been called 54 55my $Dir; # Directory in which coverage will be 56 # collected 57my $DB = "cover_db"; # DB name 58my $Merge = 1; # Merge databases 59my $Summary = 1; # Output coverage summary 60my $Subs_only = 0; # Coverage only for sub bodies 61my $Self_cover_run = 0; # Covering Devel::Cover now 62my $Loose_perms = 0; # Use loose permissions in the cover DB 63 64my @Ignore; # Packages to ignore 65my @Inc; # Original @INC to ignore 66my @Select; # Packages to select 67my @Ignore_re; # Packages to ignore 68my @Inc_re; # Original @INC to ignore 69my @Select_re; # Packages to select 70 71my $Pod = $INC{"Pod/Coverage/CountParents.pm"} ? "Pod::Coverage::CountParents" 72 : $INC{"Pod/Coverage.pm"} ? "Pod::Coverage" 73 : ""; # Type of pod coverage available 74my %Pod; # Pod coverage data 75 76my @Cvs; # All the Cvs we want to cover 77my %Cvs; # All the Cvs we want to cover 78my @Subs; # All the subs we want to cover 79my $Cv; # Cv we are looking in 80my $Sub_name; # Name of the sub we are looking in 81my $Sub_count; # Count for multiple subs on same line 82 83my $Coverage; # Raw coverage data 84my $Structure; # Structure of the files 85my $Digests; # Digests of the files 86 87my %Criteria; # Names of coverage criteria 88my %Coverage; # Coverage criteria to collect 89my %Coverage_options; # Options for overage criteria 90 91my %Run; # Data collected from the run 92 93my $Const_right = qr/^(?:const|s?refgen|gelem|die|undef|bless|anon(?:list|hash)| 94 scalar|return|last|next|redo|goto)$/x; 95 # constant ops 96 97our $File; # Last filename we saw. (localised) 98our $Line; # Last line number we saw. (localised) 99our $Collect; # Whether or not we are collecting 100 # coverage data. We make two passes 101 # over conditions. (localised) 102our %Files; # Whether we are interested in files 103 # Used in runops function 104our $Replace_ops; # Whether we are replacing ops 105our $Silent; # Output nothing. Can be used anywhere 106our $Self_cover; # Coverage of Devel::Cover 107 108BEGIN { 109 ($File, $Line, $Collect) = ("", 0, 1); 110 $Silent = ($ENV{HARNESS_PERL_SWITCHES} || "") =~ /Devel::Cover/ || 111 ($ENV{PERL5OPT} || "") =~ /Devel::Cover/; 112 *OUT = $ENV{DEVEL_COVER_DEBUG} ? *STDERR : *STDOUT; 113 114 if ($^X =~ /(apache2|httpd)$/) { 115 # mod_perl < 2.0.8 116 @Inc = @Devel::Cover::Inc::Inc; 117 } else { 118 # Can't get @INC via eval `` in taint mode, revert to default value 119 if (${^TAINT}) { 120 @Inc = @Devel::Cover::Inc::Inc; 121 } else { 122 eval { 123 local %ENV = %ENV; 124 # Clear *PERL* variables, but keep PERL5?LIB for local::lib 125 # environments 126 /perl/i and !/^PERL5?LIB$/ and delete $ENV{$_} for keys %ENV; 127 my $cmd = "$^X -MData::Dumper -e " . '"print Dumper \@INC"'; 128 my $VAR1; 129 # print STDERR "Running [$cmd]\n"; 130 eval `$cmd`; 131 @Inc = @$VAR1; 132 }; 133 if ($@) { 134 print STDERR __PACKAGE__, 135 ": Error getting \@INC: $@\n", 136 "Reverting to default value for Inc.\n"; 137 @Inc = @Devel::Cover::Inc::Inc; 138 } 139 } 140 } 141 142 @Inc = map { -d $_ ? ($_ eq "." ? $_ : Cwd::abs_path($_)) : () } @Inc; 143 144 @Inc = remove_contained_paths(getcwd, @Inc); 145 146 @Ignore = ("/Devel/Cover[./]") unless $Self_cover = $ENV{DEVEL_COVER_SELF}; 147 # $^P = 0x004 | 0x010 | 0x100 | 0x200; 148 # $^P = 0x004 | 0x100 | 0x200; 149 $^P |= 0x004 | 0x100; 150} 151 152sub version { $VERSION } 153 154if (0 && $Config{useithreads}) { 155 eval "use threads"; 156 157 no warnings "redefine"; 158 159 my $original_join; 160 BEGIN { $original_join = \&threads::join } 161 # print STDERR "original_join: $original_join\n"; 162 163 # $original_join = sub { print STDERR "j\n" }; 164 165 # sub threads::join 166 *threads::join = sub { 167 # print STDERR "threads::join- ", \&threads::join, "\n"; 168 # print STDERR "original_join- $original_join\n"; 169 my $self = shift; 170 print STDERR "(joining thread ", $self->tid, ")\n"; 171 my @ret = $original_join->($self, @_); 172 print STDERR "(returning <@ret>)\n"; 173 @ret 174 }; 175 176 my $original_destroy; 177 BEGIN { $original_destroy = \&threads::DESTROY } 178 179 *threads::DESTROY = sub { 180 my $self = shift; 181 print STDERR "(destroying thread ", $self->tid, ")\n"; 182 $original_destroy->($self, @_); 183 }; 184 185 # print STDERR "threads::join: ", \&threads::join, "\n"; 186 187 my $new = \&threads::new; 188 *threads::new = *threads::create = sub { 189 my $class = shift; 190 my $sub = shift; 191 my $wantarray = wantarray; 192 193 $new->( 194 $class, 195 sub { 196 print STDERR "Starting thread\n"; 197 set_coverage(keys %Coverage); 198 my $ret = [ $sub->(@_) ]; 199 print STDERR "Ending thread\n"; 200 report() if $Initialised; 201 print STDERR "Ended thread\n"; 202 $wantarray ? @{$ret} : $ret->[0]; 203 }, 204 @_ 205 ); 206 }; 207} 208 209{ 210 sub check { 211 return unless $Initialised; 212 213 check_files(); 214 215 set_coverage(keys %Coverage); 216 my @coverage = get_coverage(); 217 %Coverage = map { $_ => 1 } @coverage; 218 219 delete $Coverage{path}; # not done yet 220 my $nopod = ""; 221 if (!$Pod && exists $Coverage{pod}) { 222 delete $Coverage{pod}; # Pod::Coverage unavailable 223 $nopod = <<EOM; 224 Pod coverage is unavailable. Please install Pod::Coverage from CPAN. 225EOM 226 } 227 228 set_coverage(keys %Coverage); 229 @coverage = get_coverage(); 230 my $last = pop @coverage || ""; 231 232 print OUT __PACKAGE__, " $VERSION: Collecting coverage data for ", 233 join(", ", @coverage), 234 @coverage ? " and " : "", 235 "$last.\n", 236 $nopod, 237 $Subs_only ? " Collecting for subroutines only.\n" : "", 238 $ENV{MOD_PERL} ? " Collecting under $ENV{MOD_PERL}\n" : "", 239 "Selecting packages matching:", join("\n ", "", @Select), "\n", 240 "Ignoring packages matching:", join("\n ", "", @Ignore), "\n", 241 "Ignoring packages in:", join("\n ", "", @Inc), "\n" 242 unless $Silent; 243 244 populate_run(); 245 } 246 247 no warnings "void"; # avoid "Too late to run CHECK block" warning 248 CHECK { check } 249} 250 251{ 252 my $run_end = 0; 253 sub first_end { 254 # print STDERR "**** END 1 - $run_end\n"; 255 set_last_end() unless $run_end++ 256 } 257 258 my $run_init = 0; 259 sub first_init { 260 # print STDERR "**** INIT 1 - $run_init\n"; 261 collect_inits() unless $run_init++ 262 } 263} 264 265sub last_end { 266 # print STDERR "**** END 2 - [$Initialised]\n"; 267 report() if $Initialised; 268 # print STDERR "**** END 2 - ended\n"; 269} 270 271{ 272 no warnings "void"; # avoid "Too late to run ... block" warning 273 INIT {} # dummy sub to make sure PL_initav is set up and populated 274 END {} # dummy sub to make sure PL_endav is set up and populated 275 CHECK { set_first_init_and_end() } # we really want to be first 276} 277 278sub CLONE { 279 print STDERR <<EOM; 280 281Unfortunately, Devel::Cover does not yet work with threads. I have done 282some work in this area, but there is still more to be done. 283 284EOM 285 require POSIX; 286 POSIX::_exit(1); 287} 288 289$Replace_ops = !$Self_cover; 290 291sub import { 292 return if $Initialised; 293 294 my $class = shift; 295 296 # Die tainting 297 # Anyone using this module can do worse things than messing with tainting 298 my $options = ($ENV{DEVEL_COVER_OPTIONS} || "") =~ /(.*)/ ? $1 : ""; 299 my @o = (@_, split ",", $options); 300 defined or $_ = "" for @o; 301 # print STDERR __PACKAGE__, ": Parsing options from [@o]\n"; 302 303 my $blib = -d "blib"; 304 @Inc = () if "@o" =~ /-inc /; 305 @Ignore = () if "@o" =~ /-ignore /; 306 @Select = () if "@o" =~ /-select /; 307 while (@o) 308 { 309 local $_ = shift @o; 310 /^-silent/ && do { $Silent = shift @o; next }; 311 /^-dir/ && do { $Dir = shift @o; next }; 312 /^-db/ && do { $DB = shift @o; next }; 313 /^-loose_perms/ && do { $Loose_perms = shift @o; next }; 314 /^-merge/ && do { $Merge = shift @o; next }; 315 /^-summary/ && do { $Summary = shift @o; next }; 316 /^-blib/ && do { $blib = shift @o; next }; 317 /^-subs_only/ && do { $Subs_only = shift @o; next }; 318 /^-replace_ops/ && do { $Replace_ops = shift @o; next }; 319 /^-coverage/ && 320 do { $Coverage{+shift @o} = 1 while @o && $o[0] !~ /^[-+]/; next }; 321 /^[-+]ignore/ && 322 do { push @Ignore, shift @o while @o && $o[0] !~ /^[-+]/; next }; 323 /^[-+]inc/ && 324 do { push @Inc, shift @o while @o && $o[0] !~ /^[-+]/; next }; 325 /^[-+]select/ && 326 do { push @Select, shift @o while @o && $o[0] !~ /^[-+]/; next }; 327 warn __PACKAGE__ . ": Unknown option $_ ignored\n"; 328 } 329 330 if ($blib) { 331 eval "use blib"; 332 for (@INC) { $_ = $1 if ref $_ ne 'CODE' && /(.*)/ } # Die tainting 333 push @Ignore, "^t/", '\\.t$', '^test\\.pl$'; 334 } 335 336 my $ci = $^O eq "MSWin32"; 337 @Select_re = map qr/$_/, @Select; 338 @Ignore_re = map qr/$_/, @Ignore; 339 @Inc_re = map $ci ? qr/^\Q$_\//i : qr/^\Q$_\//, @Inc; 340 341 bootstrap Devel::Cover $VERSION; 342 343 if (defined $Dir) { 344 $Dir = $1 if $Dir =~ /(.*)/; # Die tainting 345 } else { 346 $Dir = $1 if Cwd::getcwd() =~ /(.*)/; 347 } 348 349 $DB = File::Spec->rel2abs($DB, $Dir); 350 unless (mkdir $DB) { 351 die "Can't mkdir $DB: $!" unless -d $DB; 352 } 353 chmod 0777, $DB if $Loose_perms; 354 $DB = $1 if abs_path($DB) =~ /(.*)/; 355 Devel::Cover::DB->delete($DB) unless $Merge; 356 357 %Files = (); # start gathering file information from scratch 358 359 for my $c (Devel::Cover::DB->new->criteria) { 360 my $func = "coverage_$c"; 361 no strict "refs"; 362 $Criteria{$c} = $func->(); 363 } 364 365 for (keys %Coverage) { 366 my @c = split /-/, $_; 367 if (@c > 1) { 368 $Coverage{shift @c} = \@c; 369 delete $Coverage{$_}; 370 } 371 delete $Coverage{$_} unless length; 372 } 373 %Coverage = (all => 1) unless keys %Coverage; 374 # print STDERR "Coverage: ", Dumper \%Coverage; 375 %Coverage_options = %Coverage; 376 377 $Initialised = 1; 378 379 if ($ENV{MOD_PERL}) { 380 eval "BEGIN {}"; 381 check(); 382 set_first_init_and_end(); 383 } 384} 385 386sub populate_run { 387 my $self = shift; 388 389 $Run{OS} = $^O; 390 $Run{perl} = $] < 5.010 ? join ".", map ord, split //, $^V 391 : sprintf "%vd", $^V; 392 $Run{dir} = $Dir; 393 $Run{run} = $0; 394 $Run{name} = $Dir; 395 $Run{version} = "unknown"; 396 397 my $mymeta = "$Dir/MYMETA.json"; 398 if (-e $mymeta) { 399 eval { 400 require Devel::Cover::DB::IO::JSON; 401 my $io = Devel::Cover::DB::IO::JSON->new; 402 my $json = $io->read($mymeta); 403 $Run{$_} = $json->{$_} for qw( name version abstract ); 404 } 405 } elsif ($Dir =~ m|.*/([^/]+)$|) { 406 my $filename = $1; 407 eval { 408 require CPAN::DistnameInfo; 409 my $dinfo = CPAN::DistnameInfo->new($filename); 410 $Run{name} = $dinfo->dist; 411 $Run{version} = $dinfo->version; 412 } 413 } 414 415 $Run{start} = get_elapsed() / 1e6; 416} 417 418sub cover_names_to_val 419{ 420 my $val = 0; 421 for my $c (@_) { 422 if (exists $Criteria{$c}) { 423 $val |= $Criteria{$c}; 424 } elsif ($c eq "all" || $c eq "none") { 425 my $func = "coverage_$c"; 426 no strict "refs"; 427 $val |= $func->(); 428 } else { 429 warn __PACKAGE__ . qq(: Unknown coverage criterion "$c" ignored.\n); 430 } 431 } 432 $val; 433} 434 435sub set_coverage { set_criteria(cover_names_to_val(@_)) } 436sub add_coverage { add_criteria(cover_names_to_val(@_)) } 437sub remove_coverage { remove_criteria(cover_names_to_val(@_)) } 438 439sub get_coverage { 440 return unless defined wantarray; 441 my @names; 442 my $val = get_criteria(); 443 for my $c (sort keys %Criteria) { 444 push @names, $c if $val & $Criteria{$c}; 445 } 446 return wantarray ? @names : "@names"; 447} 448 449{ 450 451my %File_cache; 452 453# Recursion in normalised_file() is bad. It can happen if a call from the sub 454# evals something which wants to load a new module. This has happened with 455# the Storable backend. I don't think it happens with the JSON backend. 456my $Normalising; 457 458sub normalised_file { 459 my ($file) = @_; 460 461 return $File_cache{$file} if exists $File_cache{$file}; 462 return $file if $Normalising; 463 $Normalising = 1; 464 465 my $f = $file; 466 $file =~ s/ \(autosplit into .*\)$//; 467 $file =~ s/^\(eval in .*\) //; 468 # print STDERR "file is <$file>\ncoverage: ", Dumper coverage(0); 469 if (exists coverage(0)->{module} && exists coverage(0)->{module}{$file} && 470 !File::Spec->file_name_is_absolute($file)) { 471 my $m = coverage(0)->{module}{$file}; 472 # print STDERR "Loaded <$file> <$m->[0]> from <$m->[1]> "; 473 $file = File::Spec->rel2abs($file, $m->[1]); 474 # print STDERR "as <$file> "; 475 } 476 if ($] >= 5.008) { 477 my $inc; 478 $inc ||= $file =~ $_ for @Inc_re; 479 # warn "inc for [$file] is [$inc] @Inc_re"; 480 if ($inc && ($^O eq "MSWin32" || $^O eq "cygwin")) { 481 # Windows' Cwd::_win32_cwd() calls eval which will recurse back 482 # here if we call abs_path, so we just assume it's normalised. 483 # warn "giving up on getting normalised filename from <$file>\n"; 484 } else { 485 # print STDERR "getting abs_path <$file> "; 486 if (-e $file) { # Windows likes the file to exist 487 my $abs; 488 $abs = abs_path($file) unless -l $file; # leave symbolic links 489 # print STDERR "giving <$abs> "; 490 $file = $abs if defined $abs; 491 } 492 } 493 # print STDERR "finally <$file> <$Dir>\n"; 494 } 495 $file =~ s|\\|/|g if $^O eq "MSWin32"; 496 $file =~ s|^\Q$Dir\E/|| if defined $Dir; 497 498 $Digests ||= Devel::Cover::DB::Digests->new(db => $DB); 499 $file = $Digests->canonical_file($file); 500 501 # print STDERR "File: $f => $file\n"; 502 503 $Normalising = 0; 504 $File_cache{$f} = $file 505} 506 507} 508 509sub get_location { 510 my ($op) = @_; 511 512 # print STDERR "get_location ", $op, "\n"; 513 # use Carp "cluck"; cluck("from here"); 514 return unless $op->can("file"); # How does this happen? 515 $File = $op->file; 516 $Line = $op->line; 517 # print STDERR "$File:$Line\n"; 518 519 # If there's an eval, get the real filename. Enabled from $^P & 0x100. 520 while ($File =~ /^\(eval \d+\)\[(.*):(\d+)\]/) { 521 ($File, $Line) = ($1, $2); 522 } 523 $File = normalised_file($File); 524 525 if (!exists $Run{vec}{$File} && $Run{collected}) { 526 my %vec; 527 @vec{@{$Run{collected}}} = (); 528 delete $vec{time}; 529 $vec{subroutine}++ if exists $vec{pod}; 530 @{$Run{vec}{$File}{$_}}{"vec", "size"} = ("", 0) for keys %vec; 531 } 532} 533 534my $find_filename = qr/ 535 (?:^\(eval\s \d+\)\[(.+):\d+\]) | 536 (?:^\(eval\sin\s\w+\)\s(.+)) | 537 (?:\(defined\sat\s(.+)\sline\s\d+\)) | 538 (?:\[from\s(.+)\sline\s\d+\]) 539/x; 540 541sub use_file { 542 # If we're in global destruction, forget it 543 return unless $find_filename; 544 545 my ($file) = @_; 546 547 # print STDERR "use_file($file)\n"; 548 549 # die "bad file" unless length $file; 550 551 # If you call your file something that matches $find_filename then things 552 # might go awry. But it would be silly to do that, so don't. This little 553 # optimisation provides a reasonable speedup. 554 return $Files{$file} if exists $Files{$file}; 555 556 # just don't call your filenames 0 557 while ($file =~ $find_filename) { $file = $1 || $2 || $3 || $4 } 558 $file =~ s/ \(autosplit into .*\)$//; 559 560 # print STDERR "==> use_file($file)\n"; 561 562 return $Files{$file} if exists $Files{$file}; 563 return 0 if $file =~ /\(eval \d+\)/ || 564 $file =~ /^\.\.[\/\\]\.\.[\/\\]lib[\/\\](?:Storable|POSIX).pm$/; 565 566 my $f = normalised_file($file); 567 568 # print STDERR "checking <$file> <$f>\n"; 569 # print STDERR "checking <$file> <$f> against ", 570 # "select(@Select_re), ignore(@Ignore_re), inc(@Inc_re)\n"; 571 572 for (@Select_re) { return $Files{$file} = 1 if $f =~ $_ } 573 for (@Ignore_re) { return $Files{$file} = 0 if $f =~ $_ } 574 for (@Inc_re) { return $Files{$file} = 0 if $f =~ $_ } 575 576 # system "pwd; ls -l '$file'"; 577 $Files{$file} = -e $file ? 1 : 0; 578 print STDERR __PACKAGE__ . qq(: Can't find file "$file" (@_): ignored.\n) 579 unless $Files{$file} || $Silent 580 || $file =~ $Devel::Cover::DB::Ignore_filenames; 581 582 add_cvs(); # add CVs now in case of symbol table manipulation 583 $Files{$file} 584} 585 586sub check_file { 587 my ($cv) = @_; 588 589 return unless ref($cv) eq "B::CV"; 590 591 my $op = $cv->START; 592 return unless ref($op) eq "B::COP"; 593 594 my $file = $op->file; 595 my $use = use_file($file); 596 # printf STDERR "%6s $file\n", $use ? "use" : "ignore"; 597 598 $use 599} 600 601sub B::GV::find_cv { 602 my $cv = $_[0]->CV; 603 return unless $$cv; 604 605 # print STDERR "find_cv $$cv\n" if check_file($cv); 606 $Cvs{$cv} ||= $cv if check_file($cv); 607 if ($cv->can("PADLIST") && 608 $cv->PADLIST->can("ARRAY") && 609 $cv->PADLIST->ARRAY && 610 $cv->PADLIST->ARRAY->can("ARRAY")) { 611 $Cvs{$_} ||= $_ 612 for grep ref eq "B::CV" && check_file($_), $cv->PADLIST->ARRAY->ARRAY; 613 } 614} 615 616sub sub_info { 617 my ($cv) = @_; 618 my ($name, $start) = ("--unknown--", 0); 619 my $gv = $cv->GV; 620 if ($gv && !$gv->isa("B::SPECIAL")) { 621 return unless $gv->can("SAFENAME"); 622 $name = $gv->SAFENAME; 623 # print STDERR "--[$name]--\n"; 624 $name =~ s/(__ANON__)\[.+:\d+\]/$1/ if defined $name; 625 } 626 # my $op = sub { my ($t, $o) = @_; print "$t\n"; $o->debug }; 627 my $root = $cv->ROOT; 628 # $op->(root => $root); 629 if ($root->can("first")) { 630 my $lineseq = $root->first; 631 # $op->(lineseq => $lineseq); 632 if ($lineseq->can("first")) { 633 # normal case 634 $start = $lineseq->first; 635 # $op->(start => $start); 636 # signatures 637 if ($start->name eq "null" && $start->can("first")) { 638 my $lineseq2 = $start->first; 639 # $op->(lineseq2 => $lineseq2); 640 if ($lineseq2->name eq "lineseq" && $lineseq2->can("first")) { 641 my $cop = $lineseq2->first; 642 # $op->(cop => $cop); 643 $start = $cop if $cop->name eq "nextstate"; 644 } 645 } 646 } elsif ($lineseq->name eq "nextstate") { 647 # completely empty sub - sub empty { } 648 $start = $lineseq; 649 } 650 } 651 ($name, $start) 652} 653 654sub add_cvs { 655 $Cvs{$_} ||= $_ for grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY; 656} 657 658sub check_files { 659 # print STDERR "Checking files\n"; 660 661 add_cvs(); 662 663 my %seen_pkg; 664 my %seen_cv; 665 666 walksymtable(\%main::, "find_cv", sub { !$seen_pkg{$_[0]}++ }); 667 668 my $l = sub { 669 my ($cv) = @_; 670 my $line = 0; 671 my ($name, $start) = sub_info($cv); 672 if ($start) { 673 local ($Line, $File); 674 get_location($start); 675 $line = $Line; 676 # print STDERR "$name - $File:$Line\n"; 677 } 678 ($line, $name) 679 }; 680 681 # print Dumper \%Cvs; 682 683 @Cvs = map $_->[0], 684 sort { $a->[1] <=> $b->[1] || $a->[2] cmp $b->[2] } 685 map [ $_, $l->($_) ], 686 grep !$seen_cv{$$_}++, 687 values %Cvs; 688 689 # Hack to bump up the refcount of the subs. If we don't do this then the 690 # subs in some modules don't seem to be around when we get to looking at 691 # them. I'm not sure why this is, and it seems to me that this hack could 692 # affect the order of destruction, but I've not seen any problems. Yet. 693 @Subs = map $_->object_2svref, @Cvs; 694} 695 696my %Seen; 697 698sub report { 699 local $@; 700 eval { _report() }; 701 if ($@) { 702 print STDERR <<"EOM" unless $Silent; 703Devel::Cover: Oops, it looks like something went wrong writing the coverage. 704 It's possible that more bad things may happen but we'll try to 705 carry on anyway as if nothing happened. At a minimum you'll 706 probably find that you are missing coverage. If you're 707 interested, the problem was: 708 709$@ 710 711EOM 712 } 713 return unless $Self_cover; 714 $Self_cover_run = 1; 715 _report(); 716} 717 718sub _report { 719 local @SIG{qw(__DIE__ __WARN__)}; 720 # $SIG{__DIE__} = \&Carp::confess; 721 722 $Run{finish} = get_elapsed() / 1e6; 723 724 die "Devel::Cover::import() not run: " . 725 "did you require instead of use Devel::Cover?\n" 726 unless defined $Dir; 727 728 my @collected = get_coverage(); 729 return unless @collected; 730 set_coverage("none") unless $Self_cover; 731 732 my $starting_dir = $1 if Cwd::getcwd() =~ /(.*)/; 733 chdir $Dir or die __PACKAGE__ . ": Can't chdir $Dir: $!\n"; 734 735 $Run{collected} = \@collected; 736 $Structure = Devel::Cover::DB::Structure->new( 737 base => $DB, 738 loose_perms => $Loose_perms, 739 ); 740 $Structure->read_all; 741 $Structure->add_criteria(@collected); 742 # print STDERR "Start structure: ", Dumper $Structure; 743 744 # print STDERR "Processing cover data\n@Inc\n"; 745 $Coverage = coverage(1) || die "No coverage data available.\n"; 746 # print STDERR Dumper $Coverage; 747 748 check_files(); 749 750 unless ($Subs_only) { 751 get_cover(main_cv, main_root); 752 get_cover_progress("BEGIN block", 753 B::begin_av()->isa("B::AV") ? B::begin_av()->ARRAY : ()); 754 if (exists &B::check_av) { 755 get_cover_progress("CHECK block", 756 B::check_av()->isa("B::AV") ? B::check_av()->ARRAY : ()); 757 } 758 # get_ends includes INIT blocks 759 get_cover_progress("END/INIT block", 760 get_ends()->isa("B::AV") ? get_ends()->ARRAY : ()); 761 } 762 # print STDERR "--- @Cvs\n"; 763 get_cover_progress("CV", @Cvs); 764 765 my %files; 766 $files{$_}++ for keys %{$Run{count}}, keys %{$Run{vec}}; 767 for my $file (sort keys %files) { 768 # print STDERR "looking at $file\n"; 769 unless (use_file($file)) { 770 # print STDERR "deleting $file\n"; 771 delete $Run{count}->{$file}; 772 delete $Run{vec} ->{$file}; 773 $Structure->delete_file($file); 774 next; 775 } 776 777 # $Structure->add_digest($file, \%Run); 778 779 for my $run (keys %{$Run{vec}{$file}}) { 780 delete $Run{vec}{$file}{$run} unless $Run{vec}{$file}{$run}{size}; 781 } 782 783 $Structure->store_counts($file); 784 } 785 786 # print STDERR "End structure: ", Dumper $Structure; 787 788 my $run = time . ".$$." . sprintf "%05d", rand 2 ** 16; 789 my $cover = Devel::Cover::DB->new( 790 base => $DB, 791 runs => { $run => \%Run }, 792 structure => $Structure, 793 loose_perms => $Loose_perms, 794 ); 795 796 my $dbrun = "$DB/runs"; 797 unless (mkdir $dbrun) { 798 die "Can't mkdir $dbrun $!" unless -d $dbrun; 799 } 800 chmod 0777, $dbrun if $Loose_perms; 801 $dbrun .= "/$run"; 802 803 print OUT __PACKAGE__, ": Writing coverage database to $dbrun\n" 804 unless $Silent; 805 $cover->write($dbrun); 806 $Digests->write; 807 $cover->print_summary if $Summary && !$Silent; 808 809 if ($Self_cover && !$Self_cover_run) { 810 $cover->delete; 811 delete $Run{vec}; 812 } 813 chdir $starting_dir; 814} 815 816sub add_subroutine_cover { 817 my ($op) = @_; 818 819 get_location($op); 820 return unless $File; 821 822 # print STDERR "Subroutine $Sub_name $File:$Line: ", $op->name, "\n"; 823 824 my $key = get_key($op); 825 my $val = $Coverage->{statement}{$key} || 0; 826 my ($n, $new) = $Structure->add_count("subroutine"); 827 # print STDERR "******* subroutine $n - $new\n"; 828 $Structure->add_subroutine($File, [ $Line, $Sub_name ]) if $new; 829 $Run{count}{$File}{subroutine}[$n] += $val; 830 my $vec = $Run{vec}{$File}{subroutine}; 831 vec($vec->{vec}, $n, 1) = $val ? 1 : 0; 832 $vec->{size} = $n + 1; 833} 834 835sub add_statement_cover { 836 my ($op) = @_; 837 838 get_location($op); 839 return unless $File; 840 841 # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n"; 842 843 $Run{digests}{$File} ||= $Structure->set_file($File); 844 my $key = get_key($op); 845 my $val = $Coverage->{statement}{$key} || 0; 846 my ($n, $new) = $Structure->add_count("statement"); 847 # print STDERR "Stmt $File:$Line - $n, $new\n"; 848 $Structure->add_statement($File, $Line) if $new; 849 $Run{count}{$File}{statement}[$n] += $val; 850 my $vec = $Run{vec}{$File}{statement}; 851 vec($vec->{vec}, $n, 1) = $val ? 1 : 0; 852 $vec->{size} = $n + 1; 853 no warnings "uninitialized"; 854 $Run{count}{$File}{time}[$n] += $Coverage->{time}{$key} 855 if $Coverage{time} && 856 exists $Coverage->{time} && exists $Coverage->{time}{$key}; 857} 858 859sub add_branch_cover { 860 return unless $Collect && $Coverage{branch}; 861 862 my ($op, $type, $text, $file, $line) = @_; 863 864 # return unless $Seen{branch}{$$op}++; 865 866 $text =~ s/^\s+//; 867 $text =~ s/\s+$//; 868 869 my $key = get_key($op); 870 my $c = $Coverage->{condition}{$key}; 871 872 no warnings "uninitialized"; 873 # warn "add_branch_cover $File:$Line [$type][@{[join ', ', @$c]}]\n"; 874 875 if ($type eq "and" || 876 $type eq "or" || 877 ($type eq "elsif" && !exists $Coverage->{branch}{$key})) { 878 # and => this could also be a plain if with no else or elsif 879 # or => this could also be an unless with no else or elsif 880 # elsif => no subsequent elsifs or elses 881 # True path taken if not short circuited. 882 # False path taken if short circuited. 883 $c = [ $c->[1] + $c->[2], $c->[3] ]; 884 # print STDERR "branch $type [@$c]\n"; 885 } else { 886 $c = $Coverage->{branch}{$key} || [0, 0]; 887 } 888 889 my ($n, $new) = $Structure->add_count("branch"); 890 $Structure->add_branch($file, [ $line, { text => $text } ]) if $new; 891 my $ccount = $Run{count}{$file}; 892 if (exists $ccount->{branch}[$n]) { 893 $ccount->{branch}[$n][$_] += $c->[$_] for 0 .. $#$c; 894 } else { 895 $ccount->{branch}[$n] = $c; 896 my $vec = $Run{vec}{$File}{branch}; 897 vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; 898 } 899 900 # warn "branch $type %x [@$c] => [@{$ccount->{branch}[$n]}]\n", $$op; 901} 902 903sub add_condition_cover { 904 my ($op, $strop, $left, $right) = @_; 905 906 return unless $Collect && $Coverage{condition}; 907 908 my $key = get_key($op); 909 # warn "Condition cover $$op from $File:$Line\n"; 910 # print STDERR "left: [$left]\nright: [$right]\n"; 911 # use Carp "cluck"; cluck("from here"); 912 913 my $type = $op->name; 914 $type =~ s/assign$//; 915 $type = "or" if $type eq "dor"; 916 917 my $c = $Coverage->{condition}{$key}; 918 919 no warnings "uninitialized"; 920 921 my $count; 922 923 if ($type eq "or" || $type eq "and") { 924 my $r = $op->first->sibling; 925 my $name = $r->name; 926 $name = $r->first->name if $name eq "sassign"; 927 # TODO - exec? any others? 928 # print STDERR "Name [$name]", Dumper $c; 929 if ($c->[5] || $name =~ $Const_right) { 930 $c = [ $c->[3], $c->[1] + $c->[2] ]; 931 $count = 2; 932 # print STDERR "Special short circuit\n"; 933 } else { 934 @$c = @{$c}[$type eq "or" ? (3, 2, 1) : (3, 1, 2)]; 935 $count = 3; 936 } 937 # print STDERR "$type 3 $name [", join(",", @$c), "] $File:$Line\n"; 938 } elsif ($type eq "xor") { 939 # !l&&!r l&&!r l&&r !l&&r 940 @$c = @{$c}[3, 2, 4, 1]; 941 $count = 4; 942 } else { 943 die qq(Unknown type "$type" for conditional); 944 } 945 946 my $structure = { 947 type => "${type}_${count}", 948 op => $strop, 949 left => $left, 950 right => $right, 951 }; 952 953 my ($n, $new) = $Structure->add_count("condition"); 954 $Structure->add_condition($File, [ $Line, $structure ]) if $new; 955 my $ccount = $Run{count}{$File}; 956 if (exists $ccount->{condition}[$n]) { 957 $ccount->{condition}[$n][$_] += $c->[$_] for 0 .. $#$c; 958 } else { 959 $ccount->{condition}[$n] = $c; 960 my $vec = $Run{vec}{$File}{condition}; 961 vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; 962 } 963} 964 965*is_scope = \&B::Deparse::is_scope; 966*is_state = \&B::Deparse::is_state; 967*is_ifelse_cont = \&B::Deparse::is_ifelse_cont; 968 969{ 970 971my %Original; 972BEGIN { 973 $Original{deparse} = \&B::Deparse::deparse; 974 $Original{logop} = \&B::Deparse::logop; 975 $Original{logassignop} = \&B::Deparse::logassignop; 976} 977 978sub deparse { 979 my $self = shift; 980 my ($op, $cx) = @_; 981 982 my $deparse; 983 984 if ($Collect) { 985 my $class = B::class($op); 986 my $null = $class eq "NULL"; 987 988 my $name = $op->can("name") ? $op->name : "Unknown"; 989 990 # print STDERR "$class:$name ($$op) at $File:$Line\n"; 991 # print STDERR "[$Seen{statement}{$$op}] [$Seen{other}{$$op}]\n"; 992 # use Carp "cluck"; cluck("from here"); 993 994 return "" if $name eq "padrange"; 995 996 unless ($Seen{statement}{$$op} || $Seen{other}{$$op}) { 997 # Collect everything under here 998 local ($File, $Line) = ($File, $Line); 999 # print STDERR "Collecting $$op under $File:$Line\n"; 1000 no warnings "redefine"; 1001 my $use_dumper = $class eq 'SVOP' && $name eq 'const'; 1002 local *B::Deparse::const = \&B::Deparse::const_dumper 1003 if $use_dumper; 1004 require Data::Dumper if $use_dumper; 1005 $deparse = eval { local $^W; $Original{deparse}->($self, @_) }; 1006 $deparse =~ s/^\010+//mg if defined $deparse; 1007 $deparse = "Deparse error: $@" if $@; 1008 # print STDERR "Collected $$op under $File:$Line\n"; 1009 # print STDERR "Collect Deparse $op $$op => <$deparse>\n"; 1010 } 1011 1012 # Get the coverage on this op 1013 1014 if ($class eq "COP" && $Coverage{statement}) { 1015 # print STDERR "COP $$op, seen [$Seen{statement}{$$op}]\n"; 1016 my $nnnext = ""; 1017 eval { 1018 my $next = $op->next; 1019 my $nnext = $next && $next->next; 1020 $nnnext = $nnext && $nnext->next; 1021 }; 1022 # print STDERR "COP $$op, ", $next, " -> ", $nnext, 1023 # " -> ", $nnnext, "\n"; 1024 if ($nnnext) { 1025 add_statement_cover($op) unless $Seen{statement}{$$op}++; 1026 } 1027 } elsif (!$null && $name eq "null" 1028 && ppname($op->targ) eq "pp_nextstate" 1029 && $Coverage{statement}) { 1030 # If the current op is null, but it was nextstate, we can still 1031 # get at the file and line number, but we need to get dirty 1032 1033 bless $op, "B::COP"; 1034 # print STDERR "null $$op, seen [$Seen{statement}{$$op}]\n"; 1035 add_statement_cover($op) unless $Seen{statement}{$$op}++; 1036 bless $op, "B::$class"; 1037 } elsif ($Seen{other}{$$op}++) { 1038 # print STDERR "seen [$Seen{other}{$$op}]\n"; 1039 return "" # Only report on each op once 1040 } elsif ($name eq "cond_expr") { 1041 local ($File, $Line) = ($File, $Line); 1042 my $cond = $op->first; 1043 my $true = $cond->sibling; 1044 my $false = $true->sibling; 1045 if (!($cx < 1 && (is_scope($true) && $true->name ne "null") && 1046 (is_scope($false) || is_ifelse_cont($false)) 1047 && $self->{'expand'} < 7)) { 1048 { local $Collect; $cond = $self->deparse($cond, 8) } 1049 add_branch_cover($op, "if", "$cond ? :", $File, $Line); 1050 } else { 1051 { local $Collect; $cond = $self->deparse($cond, 1) } 1052 add_branch_cover($op, "if", "if ($cond) { }", $File, $Line); 1053 while (B::class($false) ne "NULL" && is_ifelse_cont($false)) { 1054 my $newop = $false->first; 1055 my $newcond = $newop->first; 1056 my $newtrue = $newcond->sibling; 1057 if ($newcond->name eq "lineseq") { 1058 # lineseq to ensure correct line numbers in elsif() 1059 # Bug #37302 fixed by change #33710 1060 $newcond = $newcond->first->sibling; 1061 } 1062 # last in chain is OP_AND => no else 1063 $false = $newtrue->sibling; 1064 { local $Collect; $newcond = $self->deparse($newcond, 1) } 1065 add_branch_cover($newop, "elsif", "elsif ($newcond) { }", 1066 $File, $Line); 1067 } 1068 } 1069 } 1070 } else { 1071 local ($File, $Line) = ($File, $Line); 1072 # print STDERR "Starting plain deparse at $File:$Line\n"; 1073 $deparse = eval { local $^W; $Original{deparse}->($self, @_) }; 1074 $deparse = "" unless defined $deparse; 1075 $deparse =~ s/^\010+//mg; 1076 $deparse = "Deparse error: $@" if $@; 1077 # print STDERR "Ending plain deparse at $File:$Line\n"; 1078 # print STDERR "Deparse => <$deparse>\n"; 1079 } 1080 1081 # print STDERR "Returning [$deparse]\n"; 1082 $deparse 1083} 1084 1085sub logop { 1086 my $self = shift; 1087 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; 1088 my $left = $op->first; 1089 my $right = $op->first->sibling; 1090 # print STDERR "left [$left], right [$right]\n"; 1091 my ($file, $line) = ($File, $Line); 1092 1093 if ($cx < 1 && is_scope($right) && $blockname && $self->{expand} < 7) { 1094 # print STDERR 'if ($a) {$b}', "\n"; 1095 # if ($a) {$b} 1096 $left = $self->deparse($left, 1); 1097 $right = $self->deparse($right, 0); 1098 add_branch_cover($op, $lowop, "$blockname ($left)", $file, $line) 1099 unless $Seen{branch}{$$op}++; 1100 return "$blockname ($left) {\n\t$right\n\b}\cK" 1101 } elsif ($cx < 1 && $blockname && !$self->{parens} && $self->{expand} < 7) { 1102 # print STDERR '$b if $a', "\n"; 1103 # $b if $a 1104 $right = $self->deparse($right, 1); 1105 $left = $self->deparse($left, 1); 1106 add_branch_cover($op, $lowop, "$blockname $left", $file, $line) 1107 unless $Seen{branch}{$$op}++; 1108 return "$right $blockname $left" 1109 } elsif ($cx > $lowprec && $highop) { 1110 # print STDERR '$a && $b', "\n"; 1111 # $a && $b 1112 { 1113 local $Collect; 1114 $left = $self->deparse_binop_left ($op, $left, $highprec); 1115 $right = $self->deparse_binop_right($op, $right, $highprec); 1116 } 1117 # print STDERR "left [$left], right [$right]\n"; 1118 add_condition_cover($op, $highop, $left, $right) 1119 unless $Seen{condition}{$$op}++; 1120 return $self->maybe_parens("$left $highop $right", $cx, $highprec) 1121 } else { 1122 # print STDERR '$a and $b', "\n"; 1123 # $a and $b 1124 $left = $self->deparse_binop_left ($op, $left, $lowprec); 1125 $right = $self->deparse_binop_right($op, $right, $lowprec); 1126 add_condition_cover($op, $lowop, $left, $right) 1127 unless $Seen{condition}{$$op}++; 1128 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec) 1129 } 1130} 1131 1132sub logassignop { 1133 my $self = shift; 1134 my ($op, $cx, $opname) = @_; 1135 my $left = $op->first; 1136 my $right = $op->first->sibling->first; # skip sassign 1137 $left = $self->deparse($left, 7); 1138 $right = $self->deparse($right, 7); 1139 add_condition_cover($op, $opname, $left, $right); 1140 return $self->maybe_parens("$left $opname $right", $cx, 7); 1141} 1142 1143} 1144 1145sub get_cover { 1146 my $deparse = B::Deparse->new; 1147 1148 my $cv = $deparse->{curcv} = shift; 1149 1150 ($Sub_name, my $start) = sub_info($cv); 1151 1152 # warn "get_cover: <$Sub_name>\n"; 1153 return unless defined $Sub_name; # Only happens within Safe.pm, AFAIK 1154 # return unless length $Sub_name; # Only happens with Self_cover, AFAIK 1155 1156 get_location($start) if $start; 1157 # print STDERR "[[$File:$Line]]\n"; 1158 # return unless length $File; 1159 return if length $File && !use_file($File); 1160 1161 return if !$Self_cover_run && $File =~ /Devel\/Cover/; 1162 return if $Self_cover_run && $File !~ /Devel\/Cover/; 1163 return if $Self_cover_run && 1164 $File =~ /Devel\/Cover\.pm$/ && 1165 $Sub_name eq "import"; 1166 1167 # printf STDERR "getting cover for $Sub_name ($start), %x\n", $$cv; 1168 1169 if ($start) { 1170 no warnings "uninitialized"; 1171 if ($File eq $Structure->get_file && $Line == $Structure->get_line && 1172 $Sub_name eq "__ANON__" && $Structure->get_sub_name eq "__ANON__") { 1173 # Merge instances of anonymous subs into one 1174 # TODO - multiple anonymous subs on the same line 1175 } else { 1176 my $count = $Sub_count->{$File}{$Line}{$Sub_name}++; 1177 $Structure->set_subroutine($Sub_name, $File, $Line, $count); 1178 add_subroutine_cover($start) 1179 if $Coverage{subroutine} || $Coverage{pod}; # pod requires subs 1180 } 1181 } 1182 1183 if ($Pod && $Coverage{pod}) { 1184 my $gv = $cv->GV; 1185 if ($gv && !$gv->isa("B::SPECIAL")) { 1186 my $stash = $gv->STASH; 1187 my $pkg = $stash->NAME; 1188 my $file = $cv->FILE; 1189 my %opts; 1190 $Run{digests}{$File} ||= $Structure->set_file($File); 1191 if (ref $Coverage_options{pod}) { 1192 my $p; 1193 for (@{$Coverage_options{pod}}) { 1194 if (/^package|(?:also_)?private|trust_me|pod_from|nocp$/) { 1195 $opts{$p = $_} = []; 1196 } elsif ($p) { 1197 push @{$opts{$p}}, $_; 1198 } 1199 } 1200 for $p (qw( private also_private trust_me )) { 1201 next unless exists $opts{$p}; 1202 $_ = qr/$_/ for @{$opts{$p}}; 1203 } 1204 } 1205 $Pod = "Pod::Coverage" if delete $opts{nocp}; 1206 # print STDERR "$Pod, $File:$Line ($Sub_name) [$file($pkg)]", 1207 # Dumper \%opts; 1208 if ($Pod{$pkg} ||= $Pod->new(package => $pkg, %opts)) { 1209 # print STDERR Dumper $Pod{$file}; 1210 my $covered; 1211 for ($Pod{$pkg}->covered) { 1212 $covered = 1, last if $_ eq $Sub_name; 1213 } 1214 unless ($covered) { 1215 for ($Pod{$pkg}->uncovered) { 1216 $covered = 0, last if $_ eq $Sub_name; 1217 } 1218 } 1219 # print STDERR "covered ", $covered // "undef", "\n"; 1220 if (defined $covered) { 1221 my ($n, $new) = $Structure->add_count("pod"); 1222 $Structure->add_pod($File, [ $Line, $Sub_name ]) if $new; 1223 $Run{count}{$File}{pod}[$n] += $covered; 1224 my $vec = $Run{vec}{$File}{pod}; 1225 vec($vec->{vec}, $n, 1) = $covered ? 1 : 0; 1226 $vec->{size} = $n + 1; 1227 } 1228 } 1229 } 1230 } 1231 1232 # my $dd = @_ && ref $_[0] 1233 # ? $deparse->deparse($_[0], 0) 1234 # : $deparse->deparse_sub($cv, 0); 1235 # print STDERR "get_cover: <$Sub_name>\n"; 1236 # print STDERR "[[$File:$Line]]\n"; 1237 # print STDERR "<$dd>\n"; 1238 1239 no warnings "redefine"; 1240 local *B::Deparse::deparse = \&deparse; 1241 local *B::Deparse::logop = \&logop; 1242 local *B::Deparse::logassignop = \&logassignop; 1243 1244 my $de = @_ && ref $_[0] 1245 ? $deparse->deparse($_[0], 0) 1246 : $deparse->deparse_sub($cv, 0); 1247 # print STDERR "<$de>\n"; 1248 $de 1249} 1250 1251sub _report_progress { 1252 my ($msg, $code, @items) = @_; 1253 if ($Silent) { 1254 $code->($_) for @items; 1255 return; 1256 } 1257 my $tot = @items || 1; 1258 my $prog = sub { 1259 my ($n) = @_; 1260 print OUT "\r" . __PACKAGE__ . ": " . int(100 * $n / $tot) . "% "; 1261 }; 1262 my ($old_pipe, $n, $start) = ($|, 0, time); 1263 $|++; 1264 print OUT __PACKAGE__, ": $msg\n"; 1265 for (@items) { 1266 $prog->($n++); 1267 $code->($_); 1268 } 1269 $prog->($n || 1); 1270 print OUT "- " . (time - $start) . "s taken\n"; 1271 $| = $old_pipe; 1272} 1273 1274sub get_cover_progress { 1275 my ($type, @cvs) = @_; 1276 _report_progress("getting $type coverage", sub { get_cover($_) }, @cvs); 1277} 1278 1279" 1280We have normality, I repeat we have normality. 1281Anything you still can’t cope with is therefore your own problem. 1282" 1283 1284__END__ 1285 1286=head1 NAME 1287 1288Devel::Cover - Code coverage metrics for Perl 1289 1290=head1 VERSION 1291 1292version 1.36 1293 1294=head1 SYNOPSIS 1295 1296To get coverage for an uninstalled module: 1297 1298 cover -test 1299 1300or 1301 1302 cover -delete 1303 HARNESS_PERL_SWITCHES=-MDevel::Cover make test 1304 cover 1305 1306To get coverage for an uninstalled module which uses L<Module::Build> (0.26 or 1307later): 1308 1309 ./Build testcover 1310 1311If the module does not use the t/*.t framework: 1312 1313 PERL5OPT=-MDevel::Cover make test 1314 1315If you want to get coverage for a program: 1316 1317 perl -MDevel::Cover yourprog args 1318 cover 1319 1320To alter default values: 1321 1322 perl -MDevel::Cover=-db,cover_db,-coverage,statement,time yourprog args 1323 1324=head1 DESCRIPTION 1325 1326This module provides code coverage metrics for Perl. Code coverage metrics 1327describe how thoroughly tests exercise code. By using Devel::Cover you can 1328discover areas of code not exercised by your tests and determine which tests 1329to create to increase coverage. Code coverage can be considered an indirect 1330measure of quality. 1331 1332Although it is still being developed, Devel::Cover is now quite stable and 1333provides many of the features to be expected in a useful coverage tool. 1334 1335Statement, branch, condition, subroutine, and pod coverage information is 1336reported. Statement and subroutine coverage data should be accurate. Branch 1337and condition coverage data should be mostly accurate too, although not always 1338what one might initially expect. Pod coverage comes from L<Pod::Coverage>. 1339If L<Pod::Coverage::CountParents> is available it will be used instead. 1340Coverage data for other criteria are not yet collected. 1341 1342The F<cover> program can be used to generate coverage reports. Devel::Cover 1343ships with a number of reports including various types of HTML output, textual 1344reports, a report to display missing coverage in the same format as compilation 1345errors and a report to display coverage information within the Vim editor. 1346 1347It is possible to add annotations to reports, for example you can add a column 1348to an HTML report showing who last changed a line, as determined by git blame. 1349Some annotation modules are shipped with Devel::Cover and you can easily 1350create your own. 1351 1352The F<gcov2perl> program can be used to convert gcov files to C<Devel::Cover> 1353databases. This allows you to display your C or XS code coverage together 1354with your Perl coverage, or to use any of the Devel::Cover reports to display 1355your C coverage data. 1356 1357Code coverage data are collected by replacing perl ops with functions which 1358count how many times the ops are executed. These data are then mapped back to 1359reality using the B compiler modules. There is also a statement profiling 1360facility which should not be relied on. For proper profiling use 1361L<Devel::NYTProf>. Previous versions of Devel::Cover collected coverage data by 1362replacing perl's runops function. It is still possible to switch to that mode 1363of operation, but this now gets little testing and will probably be removed 1364soon. You probably don't care about any of this. 1365 1366The most appropriate mailing list on which to discuss this module would be 1367perl-qa. See L<http://lists.perl.org/list/perl-qa.html>. 1368 1369The Devel::Cover repository can be found at 1370L<http://github.com/pjcj/Devel--Cover>. This is also where problems should be 1371reported. 1372 1373=head1 REQUIREMENTS AND RECOMMENDED MODULES 1374 1375=head2 REQUIREMENTS 1376 1377=over 1378 1379=item * Perl 5.10.0 or greater. 1380 1381The latest version of Devel::Cover on which Perl 5.8 was supported was 1.23. 1382Perl versions 5.6.1 and 5.6.2 were not supported after version 1.22. Perl 1383versions 5.6.0 and earlier were never supported. Using Devel::Cover with Perl 13845.8.7 was always problematic and frequently lead to crashes. 1385 1386Different versions of perl may give slightly different results due to changes 1387in the op tree. 1388 1389=item * The ability to compile XS extensions. 1390 1391This means a working C compiler and make program at least. If you built perl 1392from source you will have these already and they will be used automatically. 1393If your perl was built in some other way, for example you may have installed 1394it using your Operating System's packaging mechanism, you will need to ensure 1395that the appropriate tools are installed. 1396 1397=item * L<Storable> and L<Digest::MD5> 1398 1399Both are in the core in Perl 5.8.0 and above. 1400 1401=back 1402 1403=head2 REQUIRED MODULES 1404 1405=over 1406 1407=item * L<B::Debug> 1408 1409This was core before Perl 5.30.0. 1410 1411=back 1412 1413=head2 OPTIONAL MODULES 1414 1415=over 1416 1417=item * L<Template>, and either L<PPI::HTML> or L<Perl::Tidy> 1418 1419Needed if you want syntax highlighted HTML reports. 1420 1421=item * L<Pod::Coverage> (0.06 or above) or L<Pod::Coverage::CountParents> 1422 1423One is needed if you want Pod coverage. If L<Pod::Coverage::CountParents> is 1424installed, it is preferred. 1425 1426=item * L<Test::More> 1427 1428Required if you want to run Devel::Cover's own tests. 1429 1430=item * L<Test::Differences> 1431 1432Needed if the tests fail and you would like nice output telling you why. 1433 1434=item * L<Template> and L<Parallel::Iterator> 1435 1436Needed if you want to run cpancover. 1437 1438=item * L<JSON::MaybeXS> 1439 1440JSON is used to store the coverage database if it is available. JSON::MaybeXS 1441will select the best JSON backend installed. 1442 1443=back 1444 1445=head2 Use with mod_perl 1446 1447By adding C<use Devel::Cover;> to your mod_perl startup script, you should be 1448able to collect coverage information when running under mod_perl. You can 1449also add any options you need at this point. I would suggest adding this as 1450early as possible in your startup script in order to collect as much coverage 1451information as possible. 1452 1453Alternatively, add -MDevel::Cover to the parameters for mod_perl. 1454In this example, Devel::Cover will be operating in silent mode. 1455 1456 PerlSwitches -MDevel::Cover=-silent,1 1457 1458=head1 OPTIONS 1459 1460 -blib - "use blib" and ignore files matching \bt/ (default true 1461 if blib directory exists, false otherwise) 1462 -coverage criterion - Turn on coverage for the specified criterion. Criteria 1463 include statement, branch, condition, path, subroutine, 1464 pod, time, all and none (default all available) 1465 -db cover_db - Store results in coverage db (default ./cover_db) 1466 -dir path - Directory in which coverage will be collected (default 1467 cwd) 1468 -ignore RE - Set regular expressions for files to ignore (default 1469 "/Devel/Cover\b") 1470 +ignore RE - Append to regular expressions of files to ignore 1471 -inc path - Set prefixes of files to include (default @INC) 1472 +inc path - Append to prefixes of files to include 1473 -loose_perms val - Use loose permissions on all files and directories in 1474 the coverage db so that code changing EUID can still 1475 write coverage information (default off) 1476 -merge val - Merge databases, for multiple test benches (default on) 1477 -select RE - Set regular expressions of files to select (default none) 1478 +select RE - Append to regular expressions of files to select 1479 -silent val - Don't print informational messages (default off) 1480 -subs_only val - Only cover code in subroutine bodies (default off) 1481 -replace_ops val - Use op replacing rather than runops (default on) 1482 -summary val - Print summary information if val is true (default on) 1483 1484=head2 More on Coverage Options 1485 1486You can specify options to some coverage criteria. At the moment only pod 1487coverage takes any options. These are the parameters which are passed into 1488the L<Pod::Coverage> constructor. The extra options are separated by dashes, 1489and you may specify as many as you wish. For example, to specify that all 1490subroutines containing xx are private, call Devel::Cover with the option 1491-coverage,pod-also_private-xx. 1492 1493Or, to ignore all files in C<t/lib> as well as files ending in C<Foo.pm>: 1494 1495 cover -test -silent -ignore ^t/lib/,Foo.pm$ 1496 1497Note that C<-ignore> replaces any default ignore regexes. To preserve any 1498ignore regexes which have already been set, use C<+ignore>: 1499 1500 cover -test -silent +ignore ^t/lib/,Foo.pm$ 1501 1502=head1 SELECTING FILES TO COVER 1503 1504You may select the files for which you want to collect coverage data using the 1505select, ignore and inc options. The system uses the following procedure to 1506decide whether a file will be included in coverage reports: 1507 1508=over 1509 1510=item * If the file matches a RE given as a select option, it will be 1511included 1512 1513=item * Otherwise, if it matches a RE given as an ignore option, it won't be 1514included 1515 1516=item * Otherwise, if it is in one of the inc directories, it won't be 1517included 1518 1519=item * Otherwise, it will be included 1520 1521=back 1522 1523You may add to the REs to select by using +select, or you may reset the 1524selections using -select. The same principle applies to the REs to ignore. 1525 1526The inc directories are initially populated with the contents of perl's @INC 1527array. You may reset these directories using -inc, or add to them using +inc. 1528 1529Although these options take regular expressions, you should not enclose the RE 1530within // or any other quoting characters. 1531 1532The options -coverage, [+-]select, [+-]ignore and [+-]inc can be specified 1533multiple times, but they can also take multiple comma separated arguments. In 1534any case you should not add a space after the comma, unless you want the 1535argument to start with that literal space. 1536 1537=head1 UNCOVERABLE CRITERIA 1538 1539Sometimes you have code which is uncoverable for some reason. Perhaps it is 1540an else clause that cannot be reached, or a check for an error condition that 1541should never happen. You can tell Devel::Cover that certain criteria are 1542uncoverable and then they are not counted as errors when they are not 1543exercised. In fact, they are counted as errors if they are exercised. 1544 1545This feature should only be used as something of a last resort. Ideally you 1546would find some way of exercising all your code. But if you have analysed 1547your code and determined that you are not going to be able to exercise it, it 1548may be better to record that fact in some formal fashion and stop Devel::Cover 1549complaining about it, so that real problems are not lost in the noise. 1550 1551If you have uncoverable criteria I suggest not using the default HTML report 1552(with uses html_minimal at the moment) because this sometimes shows uncoverable 1553points as uncovered. Instead, you should use the html_basic report for HTML 1554output which should behave correctly in this regard. 1555 1556There are two ways to specify a construct as uncoverable, one invasive and one 1557non-invasive. 1558 1559=head2 Invasive specification 1560 1561You can use special comments in your code to specify uncoverable criteria. 1562Comments are of the form: 1563 1564 # uncoverable <criterion> [details] 1565 1566The keyword "uncoverable" must be the first text in the comment. It should be 1567followed by the name of the coverage criterion which is uncoverable. There 1568may then be further information depending on the nature of the uncoverable 1569construct. 1570 1571=head3 Statements 1572 1573The "uncoverable" comment should appear on either the same line as the 1574statement, or on the line before it: 1575 1576 $impossible++; # uncoverable statement 1577 # uncoverable statement 1578 it_has_all_gone_horribly_wrong(); 1579 1580If there are multiple statements (or any other criterion) on a line you can 1581specify which statement is uncoverable by using the "count" attribute, 1582count:n, which indicates that the uncoverable statement is the nth statement 1583on the line. 1584 1585 # uncoverable statement count:1 1586 # uncoverable statement count:2 1587 cannot_run_this(); or_this(); 1588 1589=head3 Branches 1590 1591The "uncoverable" comment should specify whether the "true" or "false" branch 1592is uncoverable. 1593 1594 # uncoverable branch true 1595 if (pi == 3) 1596 1597Both branches may be uncoverable: 1598 1599 # uncoverable branch true 1600 # uncoverable branch false 1601 if (impossible_thing_happened_one_way()) { 1602 handle_it_one_way(); # uncoverable statement 1603 } else { 1604 handle_it_another_way(); # uncoverable statement 1605 } 1606 1607If there is an elsif in the branch then it can be addressed as the second 1608branch on the line by using the "count" attribute. Further elsifs are the 1609third and fourth "count" value, and so on: 1610 1611 # uncoverable branch false count:2 1612 if ($thing == 1) { 1613 handle_thing_being_one(); 1614 } elsif ($thing == 2) { 1615 handle_thing_being_tow(); 1616 } else { 1617 die "thing can only be one or two, not $thing"; # uncoverable statement 1618 } 1619 1620=head3 Conditions 1621 1622Because of the way in which Perl short-circuits boolean operations, there are 1623three ways in which such conditionals can be uncoverable. In the case of C< 1624$x && $y> for example, the left operator may never be true, the right operator 1625may never be true, and the whole operation may never be false. These 1626conditions may be modelled thus: 1627 1628 # uncoverable branch true 1629 # uncoverable condition left 1630 # uncoverable condition false 1631 if ($x && !$y) { 1632 $x++; # uncoverable statement 1633 } 1634 1635 # uncoverable branch true 1636 # uncoverable condition right 1637 # uncoverable condition false 1638 if (!$x && $y) { 1639 } 1640 1641C<Or> conditionals are handled in a similar fashion (TODO - provide some 1642examples) but C<xor> conditionals are not properly handled yet. 1643 1644As for branches, the "count" value may be used for either conditions in elsif 1645conditionals, or for complex conditions. 1646 1647=head3 Subroutines 1648 1649A subroutine should be marked as uncoverable at the point where the first 1650statement is marked as uncoverable. Ideally all other criteria in the 1651subroutine would be marked as uncoverable automatically, but that isn't the 1652case at the moment. 1653 1654 sub z { 1655 # uncoverable subroutine 1656 $y++; # uncoverable statement 1657 } 1658 1659=head2 Non-invasive specification 1660 1661If you can't, or don't want to add coverage comments to your code, you can 1662specify the uncoverable information in a separate file. By default the files 1663PWD/.uncoverable and HOME/.uncoverable are checked. If you use the 1664-uncoverable_file parameter then the file you provide is checked as well as 1665those two files. 1666 1667The interface to managing this file is the L<cover> program, and the options 1668are: 1669 1670 -uncoverable_file 1671 -add_uncoverable_point 1672 -delete_uncoverable_point **UNIMPLEMENTED** 1673 -clean_uncoverable_points **UNIMPLEMENTED** 1674 1675The parameter for -add_uncoverable_point is a string composed of up to seven 1676space separated elements: "$file $criterion $line $count $type $class $note". 1677 1678The contents of the uncoverable file is the same, with one point per line. 1679 1680=head1 ENVIRONMENT 1681 1682=head2 User variables 1683 1684The -silent option is turned on when Devel::Cover is invoked via 1685$HARNESS_PERL_SWITCHES or $PERL5OPT. Devel::Cover tries to do the right thing 1686when $MOD_PERL is set. $DEVEL_COVER_OPTIONS is appended to any options passed 1687into Devel::Cover. 1688 1689Note that when Devel::Cover is invoked via an environment variable, any modules 1690specified on the command line, such as via the -Mmodule option, will not be 1691covered. This is because the environment variables are processed after the 1692command line and any code to be covered must appear after Devel::Cover has been 1693loaded. To work around this, Devel::Cover can also be specified on the command 1694line. 1695 1696=head2 Developer variables 1697 1698When running Devel::Cover's own test suite, $DEVEL_COVER_DEBUG turns on 1699debugging information, $DEVEL_COVER_GOLDEN_VERSION overrides Devel::Cover's 1700own idea of which golden results it should test against, and 1701$DEVEL_COVER_NO_COVERAGE runs the tests without collecting coverage. 1702$DEVEL_COVER_DB_FORMAT may be set to "Sereal", "JSON" or "Storable" to 1703override the default choice of DB format (Sereal, then JSON if either are 1704available, otherwise Storable). $DEVEL_COVER_IO_OPTIONS provides fine-grained 1705control over the DB format. For example, setting it to "pretty" when the 1706format is JSON will store the DB in a readable JSON format. $DEVEL_COVER_CPUS 1707overrides the automated detection of the number of CPUs to use in parallel 1708testing. 1709 1710=head1 ACKNOWLEDGEMENTS 1711 1712Some code and ideas cribbed from: 1713 1714=over 4 1715 1716=item * L<Devel::OpProf> 1717 1718=item * L<B::Concise> 1719 1720=item * L<B::Deparse> 1721 1722=back 1723 1724=head1 SEE ALSO 1725 1726=over 4 1727 1728=item * L<Devel::Cover::Tutorial> 1729 1730=item * L<B> 1731 1732=item * L<Pod::Coverage> 1733 1734=back 1735 1736=head1 LIMITATIONS 1737 1738There are things that Devel::Cover can't cover. 1739 1740=head2 Absence of shared dependencies 1741 1742Perl keeps track of which modules have been loaded (to avoid reloading 1743them). Because of this, it isn't possible to get coverage for a path 1744where a runtime import fails if the module being imported is one that 1745Devel::Cover uses internally. For example, suppose your program has 1746this function: 1747 1748 sub foo { 1749 eval { require Storable }; 1750 if ($@) { 1751 carp "Can't find Storable"; 1752 return; 1753 } 1754 # ... 1755 } 1756 1757You might write a test for the failure mode as 1758 1759 BEGIN { @INC = () } 1760 foo(); 1761 # check for error message 1762 1763Because Devel::Cover uses Storable internally, the import will succeed 1764(and the test will fail) under a coverage run. 1765 1766Modules used by Devel::Cover while gathering coverage: 1767 1768=over 4 1769 1770=item * L<B> 1771 1772=item * L<B::Debug> 1773 1774=item * L<B::Deparse> 1775 1776=item * L<Carp> 1777 1778=item * L<Cwd> 1779 1780=item * L<Digest::MD5> 1781 1782=item * L<File::Path> 1783 1784=item * L<File::Spec> 1785 1786=item * L<Storable> or L<JSON::MaybeXS> (and its backend) or L<Sereal> 1787 1788=back 1789 1790=head2 Redefined subroutines 1791 1792If you redefine a subroutine you may find that the original subroutine is not 1793reported on. This is because I haven't yet found a way to locate the original 1794CV. Hints, tips or patches to resolve this will be gladly accepted. 1795 1796The module Test::TestCoverage uses this technique and so should not be used in 1797conjunction with Devel::Cover. 1798 1799=head1 BUGS 1800 1801Almost certainly. 1802 1803See the BUGS file, the TODO file and the bug trackers at 1804L<https://github.com/pjcj/Devel--Cover/issues?sort=created&direction=desc&state=open> 1805and L<https://rt.cpan.org/Public/Dist/Display.html?Name=Devel-Cover> 1806 1807Please report new bugs on Github. 1808 1809=head1 LICENCE 1810 1811Copyright 2001-2019, Paul Johnson (paul@pjcj.net) 1812 1813This software is free. It is licensed under the same terms as Perl itself. 1814 1815The latest version of this software should be available on CPAN and from my 1816homepage: http://www.pjcj.net/. 1817 1818=cut 1819