view release on metacpan or  search on metacpan

lib/Devel/Cover.pm  view on Meta::CPAN

  return if $Initialised;

  my $class = shift;

  # Die tainting
  # Anyone using this module can do worse things than messing with tainting
  my $options = ($ENV{DEVEL_COVER_OPTIONS} || "") =~ /(.*)/ ? $1 : "";
  my @o       = (@_, split /,/, $options);
  defined or $_ = "" for @o;
  # print STDERR __PACKAGE__, ": Parsing options from [@o]\n";

  my $blib = -d "blib";
  @Inc    = () if "@o" =~ /-inc /;
  @Ignore = () if "@o" =~ /-ignore /;
  @Select = () if "@o" =~ /-select /;
  while (@o) {
    local $_ = shift @o;
    /^-silent/      && do { $Silent      = shift @o; next };
    /^-dir/         && do { $Dir         = shift @o; next };
    /^-db/          && do { $DB          = shift @o; next };
    /^-loose_perms/ && do { $Loose_perms = shift @o; next };
    /^-merge/       && do { $Merge       = shift @o; next };
    /^-summary/     && do { $Summary     = shift @o; next };
    /^-blib/        && do { $blib        = shift @o; next };
    /^-subs_only/   && do { $Subs_only   = shift @o; next };
    /^-replace_ops/ && do { $Replace_ops = shift @o; next };
    /^-coverage/
      && do { $Coverage{ +shift @o } = 1 while @o && $o[0] !~ /^[-+]/; next };
    /^[-+]ignore/
      && do { push @Ignore, shift @o while @o && $o[0] !~ /^[-+]/; next };
    /^[-+]inc/ && do { push @Inc, shift @o while @o && $o[0] !~ /^[-+]/; next };
    /^[-+]select/
      && do { push @Select, shift @o while @o && $o[0] !~ /^[-+]/; next };
    warn __PACKAGE__ . ": Unknown option $_ ignored\n";
  }

  if ($blib) {
    eval "use blib";
    for (@INC) { $_ = $1 if ref $_ ne 'CODE' && /(.*)/ }  # Die tainting
    push @Ignore, "^t/", '\\.t$', '^test\\.pl$';
  }

  my $ci = $^O eq "MSWin32";
  @Select_re = map qr/$_/, @Select;
  @Ignore_re = map qr/$_/, @Ignore;
  @Inc_re    = map $ci ? qr/^\Q$_\//i : qr/^\Q$_\//, @Inc;

  bootstrap Devel::Cover $VERSION;

  if (defined $Dir) {
    $Dir = $1 if $Dir =~ /(.*)/;                          # Die tainting
  } else {
    $Dir = $1 if Cwd::getcwd() =~ /(.*)/;
  }

  $DB = File::Spec->rel2abs($DB, $Dir);
  unless (mkdir $DB) {
    my $err = $!;
    die "Can't mkdir $DB as EUID $>: $err" unless -d $DB;
  }
  chmod 0777, $DB if $Loose_perms;
  $DB = $1 if abs_path($DB) =~ /(.*)/;  ## no critic (CaptureWithoutTest)
  Devel::Cover::DB->delete($DB) unless $Merge;

  %Files = ();  # start gathering file information from scratch

  for my $c (Devel::Cover::DB->new->criteria) {
    my $func = "coverage_$c";
    no strict "refs";
    $Criteria{$c} = $func->();
  }

  for (keys %Coverage) {
    my @c = split /-/;
    if (@c > 1) {
      $Coverage{ shift @c } = \@c;
      delete $Coverage{$_};
    }
    delete $Coverage{$_} unless length;
  }
  %Coverage = (all => 1) unless keys %Coverage;
  # print STDERR "Coverage: ", Dumper \%Coverage;
  %Coverage_options = %Coverage;

  $Initialised = 1;

  if ($ENV{MOD_PERL}) {
    eval "BEGIN {}";
    check();
    set_first_init_and_end();
  }
}

sub populate_run {
  my $self = shift;

  $Run{OS}   = $^O;
  $Run{perl} = sprintf "%vd", $^V;
  $Run{dir}     = $Dir;
  $Run{run}     = $0;
  $Run{name}    = $Dir;
  $Run{version} = "unknown";

  my $mymeta = "$Dir/MYMETA.json";
  if (-e $mymeta) {
    eval {
      require CPAN::Meta;
      my $json = CPAN::Meta->load_file($mymeta)->as_struct;
      $Run{$_} = $json->{$_} for qw( name version abstract );
    }
  } elsif ($Dir =~ m|.*/([^/]+)$|) {
    my $filename = $1;
    eval {
      require CPAN::DistnameInfo;
      my $dinfo = CPAN::DistnameInfo->new($filename);
      $Run{name}    = $dinfo->dist;
      $Run{version} = $dinfo->version;
    }
  }

  $Run{start} = get_elapsed() / 1e6;

lib/Devel/Cover.pm  view on Meta::CPAN

  $Structure->read_all;
  $Structure->add_criteria(@collected);
  # print STDERR "Start structure: ", Dumper $Structure;

  # print STDERR "Processing cover data\n@Inc\n";
  $Coverage = coverage(1) || die "No coverage data available.\n";
  # print STDERR Dumper $Coverage;

  check_files();

  unless ($Subs_only) {
    get_cover(main_cv, main_root);
    get_cover_progress("BEGIN block",
      B::begin_av()->isa("B::AV") ? B::begin_av()->ARRAY : ());
    if (exists &B::check_av) {
      get_cover_progress("CHECK block",
        B::check_av()->isa("B::AV") ? B::check_av()->ARRAY : ());
    }
    # get_ends includes INIT blocks
    get_cover_progress("END/INIT block",
      get_ends()->isa("B::AV") ? get_ends()->ARRAY : ());
  }
  # print STDERR "--- @Cvs\n";
  get_cover_progress("CV", @Cvs);

  my %files;
  $files{$_}++ for keys %{ $Run{count} }, keys %{ $Run{vec} };
  for my $file (sort keys %files) {
    # print STDERR "looking at $file\n";
    unless (use_file($file)) {
      # print STDERR "deleting $file\n";
      delete $Run{count}->{$file};
      delete $Run{vec}->{$file};
      $Structure->delete_file($file);
      next;
    }

    # $Structure->add_digest($file, \%Run);

    for my $run (keys %{ $Run{vec}{$file} }) {
      delete $Run{vec}{$file}{$run} unless $Run{vec}{$file}{$run}{size};
    }

    $Structure->store_counts($file);
  }

  # print STDERR "End structure: ", Dumper $Structure;

  my $run   = time . ".$$." . sprintf "%05d", rand 2**16;
  my $cover = Devel::Cover::DB->new(
    base        => $DB,
    runs        => { $run => \%Run },
    structure   => $Structure,
    loose_perms => $Loose_perms
  );

  my $dbrun = "$DB/runs";
  unless (mkdir $dbrun) {
    die "Can't mkdir $dbrun $!" unless -d $dbrun;
  }
  chmod 0777, $dbrun if $Loose_perms;
  $dbrun .= "/$run";

  print OUT __PACKAGE__, ": Writing coverage database to $dbrun\n"
    unless $Silent;
  $cover->write($dbrun);
  $Digests->write;
  $cover->print_summary if $Summary && !$Silent;

  if ($Self_cover && !$Self_cover_run) {
    $cover->delete;
    delete $Run{vec};
  }
  chdir $starting_dir if $starting_dir;
}

sub add_subroutine_cover {
  my ($op) = @_;

  get_location($op);
  return unless $File;

  # print STDERR "Subroutine $Sub_name $File:$Line: ", $op->name, "\n";

  my $key = get_key($op);
  my $val = $Coverage->{statement}{$key} || 0;
  my ($n, $new) = $Structure->add_count("subroutine");
  # print STDERR "******* subroutine $n - $new\n";
  $Structure->add_subroutine($File, [ $Line, $Sub_name ]) if $new;
  $Run{count}{$File}{subroutine}[$n] += $val;
  my $vec = $Run{vec}{$File}{subroutine};
  vec($vec->{vec}, $n, 1) = $val ? 1 : 0;
  $vec->{size} = $n + 1;
}

sub add_statement_cover {
  my ($op) = @_;

  get_location($op);
  return unless $File;

  # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n";

  $Run{digests}{$File} ||= $Structure->set_file($File);
  my $key = get_key($op);
  my $val = $Coverage->{statement}{$key} || 0;
  my ($n, $new) = $Structure->add_count("statement");
  # print STDERR "Stmt $File:$Line - $n, $new\n";
  $Structure->add_statement($File, $Line) if $new;
  $Run{count}{$File}{statement}[$n] += $val;
  my $vec = $Run{vec}{$File}{statement};
  vec($vec->{vec}, $n, 1) = $val ? 1 : 0;
  $vec->{size} = $n + 1;
  no warnings "uninitialized";
  $Run{count}{$File}{time}[$n] += $Coverage->{time}{$key}
    if $Coverage{time}
    && exists $Coverage->{time}
    && exists $Coverage->{time}{$key};
}

sub add_branch_cover {