Permalink
Browse files

import Devel::Cover 0.15

  • Loading branch information...
1 parent 2152f1e commit c8c4341851b339ca7f22868b2250fc779146c45d @pjcj committed Nov 3, 2004
Showing with 3,599 additions and 1,343 deletions.
  1. +2 −3 BUGS
  2. +18 −0 CHANGES
  3. +0 −458 Cover.pm
  4. +481 −62 Cover.xs
  5. +39 −14 MANIFEST
  6. +146 −41 Makefile.PL
  7. +13 −6 README
  8. +8 −3 TODO
  9. +100 −244 cover
  10. +41 −0 create_gold
  11. +7 −4 gcov2perl
  12. +585 −0 lib/Devel/Cover.pm
  13. +90 −0 lib/Devel/Cover/Branch.pm
  14. +17 −17 { → lib/Devel}/Cover/Condition.pm
  15. +14 −12 { → lib/Devel}/Cover/Criterion.pm
  16. +77 −24 { → lib/Devel}/Cover/DB.pm
  17. +8 −7 { → lib/Devel}/Cover/DB/File.pm
  18. +7 −4 { → lib/Devel}/Cover/Op.pm
  19. +9 −15 { → lib/Devel}/Cover/Pod.pm
  20. +329 −0 lib/Devel/Cover/Report/Html.pm
  21. +236 −0 lib/Devel/Cover/Report/Text.pm
  22. +9 −15 { → lib/Devel}/Cover/Statement.pm
  23. +187 −0 lib/Devel/Cover/Test.pm
  24. +10 −10 { → lib/Devel}/Cover/Time.pm
  25. +1 −1 { → lib/Devel}/Cover/Tutorial.pod
  26. +14 −3 session.vim
  27. +0 −61 t/Compare.pm
  28. +0 −260 t/t1.t
  29. +0 −77 t/t2.t
  30. +33 −0 templates/html/branches
  31. +14 −0 templates/html/colours
  32. +42 −0 templates/html/conditions
  33. +39 −0 templates/html/file
  34. +27 −0 templates/html/html
  35. +34 −0 templates/html/summary
  36. +93 −0 test_output/cover/cond_and
  37. +84 −0 test_output/cover/cond_or
  38. +38 −0 test_output/cover/eval1
  39. +105 −0 test_output/cover/module1
  40. +105 −0 test_output/cover/module2
  41. +83 −0 test_output/cover/t0
  42. +36 −0 test_output/cover/t1
  43. +69 −0 test_output/cover/t2
  44. +10 −2 t/T1.pm → tests/Module1.pm
  45. +45 −0 tests/Module2.pm
  46. +52 −0 tests/cond_and
  47. +45 −0 tests/cond_or
  48. +22 −0 tests/eval1
  49. +35 −0 tests/module1
  50. +35 −0 tests/module2
  51. +44 −0 tests/t0
  52. +20 −0 tests/t1
  53. +41 −0 tests/t2
View
5 BUGS
@@ -1,3 +1,2 @@
-- Testing with different versions of perl, or using TEST_VERBOSE=1 can fail.
- The coverage is genuinely different, but I have no idea why.
-- Code in modules which is not in a subroutine is not reported.
+- Code in BEGIN and END blocks is not reported.
+- Templates aren't put anywhere useful.
View
18 CHANGES
@@ -66,3 +66,21 @@ Release 0.14 - 28th February 2002
- Add a workaround for an AUTOLOAD bug in bleadperl.
- Add gcov2perl program to convert gcov files to Devel::Cover databases.
- Get rid of // comments in xs file.
+
+Release 0.15 - 5th September 2002
+ - Reinstate coverage of subs in main:: which got lost somewhere (0.11?).
+ - Bug fixes for use of uninitialised values.
+ - Automatically generate tests. Well, their infrastructure anyway.
+ - Move Cover to lib/Devel/Cover to keep case insensitive filesystems happy.
+ - Remove -detail option. (It belongs to cover.)
+ - Work on op addresses and sequence numbers instead of just op addresses,
+ to be (almost) unique.
+ - Clean up subroutine location code.
+ - Fix -select to override anything else.
+ - Add condition coverage for && and || ops.
+ - Various changes in runops_cover to try to reduce runtime.
+ - Don't use runops_cover until CHECK time.
+ - Add merge, write and file options to cover.
+ - Add branch coverage.
+ - Abstract away cover backends.
+ - Use TT for HTML output.
View
458 Cover.pm
@@ -1,458 +0,0 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
-
-# This software is free. It is licensed under the same terms as Perl itself.
-
-# The latest version of this software should be available from my homepage:
-# http://www.pjcj.net
-
-package Devel::Cover;
-
-use strict;
-use warnings;
-
-use DynaLoader ();
-
-use Devel::Cover::DB 0.14;
-use Devel::Cover::Inc 0.14;
-
-our @ISA = qw( DynaLoader );
-our $VERSION = "0.14";
-
-use B qw( class ppname main_root main_start main_cv svref_2object OPf_KIDS );
-use B::Debug;
-
-BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available.
-
-my $Covering = 1; # Coverage on.
-my $Profiling = 1; # Profiling on.
-
-my $DB = "cover_db"; # DB name.
-my $Indent = 0; # Data::Dumper indent.
-my $Merge = 1; # Merge databases.
-
-my %Packages; # Packages we are interested in.
-my @Ignore; # Packages to ignore.
-my @Inc; # Original @INC to ignore.
-my @Select; # Packages to select.
-
-my $Pod = $INC{"Pod/Coverage.pm"}; # Do pod coverage.
-
-my $Summary = 1; # Output coverage summary.
-my $Details = 0; # Output coverage details.
-
-my %Cover; # Coverage data.
-our $Cv; # Gets localised.
-my @Todo; # Subs to look at.
-my %Done; # Subs that have been seen.
-
-BEGIN { @Inc = @Devel::Cover::Inc::Inc }
-# BEGIN { $^P = 0x02 | 0x04 | 0x100 }
-BEGIN { $^P = 0x04 | 0x100 }
-
-END { report() }
-
-sub import
-{
- my $class = shift;
- @Inc = () if "@_" =~ /-inc /;
- while (@_)
- {
- local $_ = shift;
- /^-coverage/ && do { $Covering = shift; next };
- /^-db/ && do { $DB = shift; next };
- /^-details/ && do { $Details = shift; next };
- /^-indent/ && do { $Indent = shift; next };
- /^-merge/ && do { $Merge = shift; next };
- /^-profile/ && do { $Profiling = shift; next };
- /^-summary/ && do { $Summary = shift; next };
- /^-ignore/ && do { push @Ignore, shift while $_[0] !~ /^[-+]/; next };
- /^[-+]inc/ && do { push @Inc, shift while $_[0] !~ /^[-+]/; next };
- /^-select/ && do { push @Select, shift while $_[0] !~ /^[-+]/; next };
- warn __PACKAGE__ . ": Unknown option $_ ignored\n";
- }
-}
-
-sub cover
-{
- ($Covering) = @_;
- set_cover($Covering > 0);
-}
-
-sub profile
-{
- ($Profiling) = @_;
- set_profile($Profiling > 0 ? $Profiling : 0);
-}
-
-my ($F, $L) = ("", 0);
-# my $Level = 0;
-
-sub get_location
-{
- my ($op) = @_;
-
- $F = $op->file;
- $L = $op->line;
-
- # If there's an eval, get the real filename. Enabled from $^P & 0x100.
-
- ($F, $L) = ($1, $2) if $F =~/^\(eval \d+\)\[(.*):(\d+)\]/;
-
- # print STDERR "<$F> => ";
- $F =~ s/ \(autosplit into .*\)$//;
- # print STDERR "<$F>\n";
-
-}
-
-sub report
-{
- return unless $Covering > 0 || $Profiling > 0;
- cover(-1);
- profile(-1);
-
- # print "Processing cover data\n@Inc\n";
- $Cv = main_cv;
- get_subs("main");
-
- # This array should hold the top level of each package, ie all code
- # which is not part of a subroutine. main_root gets us the main
- # root (!), but TODO: something similar for other packages.
- my @roots = (main_root);
-
- INC:
- while (my ($name, $file) = each %INC)
- {
- # print "test $name => $file\n";
- for (@Select) { next INC if $file !~ /$_/ }
- for (@Ignore) { next INC if $file =~ /$_/ }
- for (@Inc) { next INC if $file =~ /^\Q$_/ }
- # print "use $name => $file\n";
- $name =~ s/\.pm$//;
- $name =~ s/\//::/g;
- $Packages{$name} = 1;
- # print "pod $name => $file\n";
- $Packages{$name} = Pod::Coverage->new(package => $name) if $Pod;
- push @roots, get_subs($name);
- }
- walk_sub($Cv, main_start);
- @Todo = sort {$a->[0] <=> $b->[0]} @Todo;
-
- for (@roots)
- {
- walk_topdown($_) unless null($_);
- }
-
- for my $sub (@Todo)
- {
- if (class($sub->[1]->CV->START) eq "COP")
- {
- # Determine whether this sub is in a package we are covering.
- my $package = $sub->[1]->CV->START->stashpv;
- next unless $Packages{$package};
-
- if ($Pod)
- {
- my $name = $sub->[1]->SAFENAME;
- get_location($sub->[1]->CV->START);
- my $covered;
- for ($Packages{$package}->covered)
- {
- $covered = 1, last if $_ eq $name;
- }
- unless ($covered)
- {
- for ($Packages{$package}->uncovered)
- {
- $covered = 0, last if $_ eq $name;
- }
- }
- push @{$Cover{$F}{pod}{$L}[0]}, $covered if defined $covered;
- }
- }
-
- local $Cv = $sub->[1]->CV;
- walk_topdown($Cv->ROOT);
- }
-
- for my $file (sort keys %Cover)
- {
- for (@Inc) { delete $Cover{$file}, last if $file =~ /^\Q$_/ }
- }
-
- my $cover = Devel::Cover::DB->new(cover => \%Cover);
- my $existing;
- eval { $existing = Devel::Cover::DB->new(db => $DB) if $Merge };
- $cover->merge($existing) if $existing;
- $cover->indent($Indent);
- $cover->write($DB);
- $cover->print_summary if $Summary;
- $cover->print_details if $Details;
-}
-
-sub walk_topdown
-{
- my ($op) = @_;
- my $class = class($op);
- my $key = pack "I*", $$op;
- my $cover = coverage()->{$key};
-
- # $Level++;
-
- # Statement coverage.
-
- if ($class eq "COP")
- {
- get_location($op);
- push @{$Cover{$F}{statement}{$L}}, [ $cover || 0 ];
- my $p = profiles()->{$key};
- push @{$Cover{$F}{time}{$L}}, [ $p ] if $p;
- }
- elsif (!null($op) &&
- $op->name eq "null"
- && ppname($op->targ) eq "pp_nextstate")
- {
- # If the current op is null, but it was nextstate, we can still
- # get at the file and line number, but we need to get dirty.
-
- my $key = pack "I*", ${$op->sibling};
- $cover = coverage()->{$key};
- my $o = $op;
- bless $o, "B::COP";
- get_location($o);
- push @{$Cover{$F}{statement}{$L}}, [ $cover || 0 ];
- my $p = profiles()->{$key};
- push @{$Cover{$F}{time}{$L}}, [ $p ] if $p;
- }
-
- # print " " x ($Level * 2), "$F:$L ", $op->name, ":$class\n";
-
- # Condition coverage.
-
- if ($op->can("flags") && ($op->flags & OPf_KIDS))
- {
- my $c;
- for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
- {
- my $cov = walk_topdown($kid);
- push @$c, $cov || 0 if $class eq "LOGOP";
- }
- push @{$Cover{$F}{condition}{$L}}, $c if $c;
- }
-
- if ($class eq "PMOP" && ${$op->pmreplroot})
- {
- walk_topdown($op->pmreplroot);
- }
-
- # $Level--;
-
- $class eq "LISTOP" ? undef : $cover
-}
-
-sub find_first
-{
- my ($op) = @_;
- my $c = coverage()->{pack "I*", $$op};
- return $c if defined $c;
- for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
- {
- if ($op->can("flags") && ($op->flags & OPf_KIDS))
- {
- my $c = find_first($kid);
- return $c if defined $c;
- }
- }
- undef
-}
-
-sub get_subs
-{
- my $pack = shift;
- # print "package $pack\n";
-
- my $stash;
- { no strict 'refs'; $stash = svref_2object(\%{$pack . "::"}) }
- my %stash = $stash->ARRAY;
-
- my $cv_outside;
-
- while (my ($key, $val) = each %stash)
- {
- if (class($val) eq "GV" && class($val->CV) ne "SPECIAL")
- {
- next if $Done{$$val}++;
-
- my $cv = $val->CV;
- todo($val, $cv);
- walk_sub($cv);
-
- # Trying to find the code in packages which is outside
- # subroutines. TODO: make it work.
- unless ($cv_outside)
- {
- do
- {
- $cv = $cv->OUTSIDE
- } while class($cv) eq "CV";
- unless (null($cv))
- {
- # $cv_outside = $cv;
- }
- }
- }
- }
-
- $cv_outside || ()
-}
-
-sub null
-{
- class(shift) eq "NULL";
-}
-
-sub is_state
-{
- my $name = $_[0]->name;
- $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
-}
-
-sub todo
-{
- my($gv, $cv) = @_;
- my $seq = (!null($cv->START) && is_state($cv->START))
- ? $cv->START->cop_seq
- : 0;
- push @Todo, [$seq, $gv];
-}
-
-sub walk_sub
-{
- my $cv = shift;
- local $Cv = $cv;
- my $op = $cv->ROOT;
- $op = shift if null($op);
- walk_tree($op) if $op && !null($op);
-}
-
-sub walk_tree
-{
- my ($op) = @_;
-
- if ($op->name eq "gv")
- {
- my $gv = class($op) eq "PADOP"
- ? (($Cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix]
- : $op->gv;
- if ($op->next->name eq "entersub")
- {
- return if $Done{$$gv}++;
- return if class($gv->CV) eq "SPECIAL";
- todo($gv, $gv->CV);
- walk_sub($gv->CV);
- }
- }
-
- if ($op->flags & OPf_KIDS)
- {
- for (my $kid = $op->first; !null($kid); $kid = $kid->sibling)
- {
- walk_tree($kid);
- }
- }
-}
-
-bootstrap Devel::Cover $VERSION;
-
-1
-
-__END__
-
-=head1 NAME
-
-Devel::Cover - Code coverage metrics for Perl
-
-=head1 SYNOPSIS
-
- perl -MDevel::Cover prog args
- cover cover_db
-
- perl -MDevel::Cover=-db,cover_db,-indent,1,-details,1 prog args
-
-=head1 DESCRIPTION
-
-This module provides code coverage metrics for Perl.
-
-If you can't guess by the version number this is an alpha release.
-
-Code coverage data are collected using a plugable runops function which
-counts how many times each op is executed. These data are then mapped
-back to reality using the B compiler modules. There is also a statement
-profiling facility which needs a better backend to be really useful.
-
-The B<cover> program can be used to generate coverage reports.
-
-At the moment, only statement, pod and time coverage information is
-reported. Condition coverage data is available, though not accurate at
-the moment. Statement coverage data should be reasonable, although
-there may be some statements which are no reported. Pod coverage comes
-from Pod::Coverage. Coverage data for other metrics are collected, but
-not reported. Coverage data for some metrics are not yet collected.
-
-The B<gcov2perl> program can be used to convert gcov files to
-Devel::Cover databases.
-
-You may find that the results don't match your expectations. I would
-imagine that at least one of them is wrong.
-
-Requirements:
-
- Perl 5.6.1 or 5.7.1.
- The ability to compile XS extensions.
- Pod::Coverage if you want pod coverage.
-
-=head1 OPTIONS
-
- -db cover_db - Store results in coverage db (default cover_db).
- -details val - Print detailed information iff val is true (default off).
- -inc path - Set prefixes of files to ignore (default @INC).
- +inc path - Append to prefixes of files to ignore.
- -ignore RE - Ignore files matching RE.
- -indent indent - Set indentation level to indent. See Data::Dumper for details.
- -merge val - Merge databases, for multiple test benches (default on).
- -profile val - Turn on profiling iff val is true (default on).
- -select RE - Only report on files matching RE.
- -summary val - Print summary information iff val is true (default on).
-
-=head1 ACKNOWLEDGEMENTS
-
-Some code and ideas cribbed from:
-
- Devel::OpProf
- B::Concise
- B::Deparse
-
-=head1 SEE ALSO
-
- Devel::Cover::Tutorial
- Data::Dumper
- B
- Pod::Coverage
-
-=head1 BUGS
-
-Huh?
-
-=head1 VERSION
-
-Version 0.14 - 28th February 2002
-
-=head1 LICENCE
-
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
-
-This software is free. It is licensed under the same terms as Perl itself.
-
-The latest version of this software should be available from my homepage:
-http://www.pjcj.net
-
-=cut
View
543 Cover.xs
@@ -26,16 +26,47 @@ extern "C" {
#define CALLOP *PL_op
#endif
-static int covering = 1,
- profiling = 1;
-
-static HV *cover_hv = 0,
- *profile_hv = 0;
+#define PDEB(a) a
+#define NDEB(a)
+#define D PerlIO_printf
+#define L Perl_debug_log
+#define svdump(sv) do_sv_dump(0, L, (SV *)sv, 0, 10, 1, 0);
+
+#define None 0x00000000
+#define Statement 0x00000001
+#define Branch 0x00000002
+#define Condition 0x00000004
+#define Path 0x00000008
+#define Pod 0x00000010
+#define Time 0x00000020
+#define All 0xffffffff
+
+static unsigned Covering = None;
+
+#define collecting(criteria) (Covering & (criteria))
+
+#define COND_WAITING 0x8000
+
+static HV *Cover_hv,
+ *Statements,
+ *Branches,
+ *Conditions,
+ *Times,
+ *Pending_conditionals;
+
+typedef int seq_t;
+#define ch_sz (sizeof(void *) + sizeof(seq_t))
+
+struct unique /* Well, we'll be fairly unlucky if it's not */
+{
+ void *addr;
+ seq_t seq;
+};
-union address /* Hack, hack, hackety hack. */
+union sequence /* Hack, hack, hackety hack. */
{
- char ch[sizeof(PL_op) + 1];
- void *plop;
+ struct unique op;
+ char ch[ch_sz + 1];
};
#ifdef HAS_GETTIMEOFDAY
@@ -54,8 +85,7 @@ extern "C" {
}
#endif
-static int
-elapsed()
+static int elapsed()
{
static struct timeval time;
static int sec = 0,
@@ -84,8 +114,7 @@ elapsed()
# endif
#endif
-static int
-cpu()
+static int cpu()
{
static struct tms time;
static int utime = 0,
@@ -109,56 +138,385 @@ cpu()
#endif /* HAS_TIMES */
+#define CAN_PROFILE defined HAS_GETTIMEOFDAY || defined HAS_TIMES
+
+/* The following comment has been superceded. There aren't enough hooks
+ * in the core to allow me to get at the seqence numbers of the ops
+ * before they get used in runops_cover. Well, I probably could do it
+ * somehow, but for now the sequence number is just used, not changed.
+ */
+
+/* Completely abuse the sequence number. It's not used for anything now
+ * anyway. In fact, I'm not sure it ever needs to be anything other
+ * than 0, -1 or something else, and the -1 is only for the benefit of
+ * the compiler. I suppose B::Concise and similar modules can use it
+ * for display purposes.
+ *
+ * Anyway, I use the MSB to store whether or not this op needs to store
+ * some condition coverage, and the rest to store my own sequence number
+ * which, when combined with the address of the op will hopefully be
+ * unique over the lifetime of the program.
+ *
+ * The MSB should be reset by the time we get to op_free, but if it's
+ * not we'll get a leak for 0x7fff. In that respect we're no different
+ * from perl itself.
+ */
+
+static void walk_reset_op_seq(OP *o)
+{
+ if (!o) return;
+ NDEB(D(L, "%p : %d\n", o, o->op_seq));
+ o->op_seq = 0;
+ if (o->op_flags & OPf_KIDS)
+ {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ walk_reset_op_seq(kid);
+ }
+}
+
+U16 get_seq(OP *o)
+{
+ static U16 max_seq = 0;
+
+ if (!o->op_seq)
+ {
+ if (max_seq++ & COND_WAITING)
+ max_seq = 1;
+ o->op_seq = max_seq;
+ }
+ return o->op_seq;
+}
+
+static char *get_key(OP *o)
+{
+ static union sequence uniq;
+
+ uniq.op.addr = o;
+ /* uniq.op.seq = get_seq(o); */
+ uniq.op.seq = o->op_seq;
+ uniq.ch[ch_sz] = 0;
+ return uniq.ch;
+}
+
+static void add_branch(OP *op, int br)
+{
+ AV *branches;
+ SV **count;
+ int c;
+ SV **tmp = hv_fetch(Branches, get_key(op), ch_sz, 1);
+ if (SvROK(*tmp))
+ branches = (AV *)SvRV(*tmp);
+ else
+ {
+ *tmp = newRV_inc((SV*) (branches = newAV()));
+ av_unshift(branches, 2);
+ }
+
+ count = av_fetch(branches, br, 1);
+ c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
+ sv_setiv(*count, c);
+ NDEB(D(L, "Adding %d conditional making %d at %p\n", cond, c, op));
+}
+
+
+#define condition_waiting(o) (get_seq(o) & COND_WAITING)
+#define condition_waiting_clear(o) (o->op_seq &= ~COND_WAITING)
+
+static void condition_waiting_set(OP *o)
+{
+ get_seq(o);
+ o->op_seq |= COND_WAITING;
+}
+
+static void add_conditional(OP *op, int cond)
+{
+ AV *conds;
+ SV **count;
+ int c;
+ SV **tmp = hv_fetch(Conditions, get_key(op), ch_sz, 1);
+ if (SvROK(*tmp))
+ conds = (AV *)SvRV(*tmp);
+ else
+ {
+ *tmp = newRV_inc((SV*) (conds = newAV()));
+ av_unshift(conds, 3);
+ }
+
+ count = av_fetch(conds, cond, 1);
+ c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
+ sv_setiv(*count, c);
+ NDEB(D(L, "Adding %d conditional making %d at %p\n", cond, c, op));
+}
-static int
-runops_cover(pTHX)
+static int runops_cover(pTHX)
{
- union address addr;
SV **count;
IV c;
+ HV *Files;
+ int collecting_here = 1;
+ char *lastfile = 0;
-#ifdef HAS_GETTIMEOFDAY
+#if CAN_PROFILE
static COP *cop = 0;
- if (!profile_hv) profile_hv = newHV();
+ int lapsed;
elapsed();
#endif
- if (!cover_hv) cover_hv = newHV();
- addr.ch[sizeof(PL_op)] = '\0';
+ NDEB(D(L, "runops_cover\n"));
- /* fprintf(stderr, "runops_cover\n"); */
- while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)))
+ if (!Cover_hv)
{
- if (covering)
+ /* TODO - this probably leaks all over the place */
+
+ SV **tmp;
+
+ Cover_hv = newHV();
+
+ tmp = hv_fetch(Cover_hv, "statement", 9, 1);
+ Statements = newHV();
+ *tmp = newRV_inc((SV*) Statements);
+
+ tmp = hv_fetch(Cover_hv, "branch", 6, 1);
+ Branches = newHV();
+ *tmp = newRV_inc((SV*) Branches);
+
+ tmp = hv_fetch(Cover_hv, "condition", 9, 1);
+ Conditions = newHV();
+ *tmp = newRV_inc((SV*) Conditions);
+
+#if CAN_PROFILE
+ tmp = hv_fetch(Cover_hv, "time", 4, 1);
+ Times = newHV();
+ *tmp = newRV_inc((SV*) Times);
+#endif
+
+ Pending_conditionals = newHV();
+ }
+
+ for (;;)
+ {
+ if (!(PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)))
+ break;
+
+ PERL_ASYNC_CHECK();
+
+ if (!Covering)
+ continue;
+
+ /* Check to see whether we are interested in this file */
+
+ if (PL_op->op_type == OP_NEXTSTATE)
{
- addr.plop = PL_op;
- count = hv_fetch(cover_hv, addr.ch, sizeof(PL_op), 1);
- c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
- sv_setiv(*count, c);
+ char *file = CopFILE(cCOP);
+ if (file && (!lastfile || lastfile && strNE(lastfile, file)))
+ {
+ Files = get_hv("Devel::Cover::Files", FALSE);
+ if (Files)
+ {
+ SV **f = hv_fetch(Files, file, strlen(file), 0);
+ collecting_here = f ? SvIV(*f) : 1;
+ NDEB(D(L, "File: %s [%d]\n", file, collecting_here));
+ }
+ lastfile = file;
+ }
}
- if (profiling && PL_curcop != cop)
+
+ if (!collecting_here)
+ continue;
+
+ /* if (collecting(Condition) && condition_waiting(PL_op)) */
+ if (collecting(Condition))
{
- addr.plop = cop;
- cop = PL_curcop;
- count = hv_fetch(profile_hv, addr.ch, sizeof(PL_op), 1);
- c = (SvTRUE(*count) ? SvIV(*count) : 0) + elapsed();
- /*
- c = (SvTRUE(*count) ? SvIV(*count) : 0) +
- profiling == 1 ? cpu() : elapsed();
- */
- sv_setiv(*count, c);
+ char *ch;
+ AV *conds;
+ SV **sv;
+ I32 i;
+
+ /* condition_waiting_clear(PL_op); */
+ ch = get_key(PL_op);
+ sv = hv_fetch(Pending_conditionals, ch, ch_sz, 0);
+
+ if (sv && SvROK(*sv))
+ {
+ conds = (AV *)SvRV(*sv);
+ NDEB(D(L, "Looking through %d conditionals\n",av_len(conds)+1));
+ for (i = 0; i <= av_len(conds); i++)
+ {
+ SV **sv = av_fetch(conds, i, 0);
+ OP *op = (OP *) SvIV(*sv);
+
+ dSP;
+ NDEB(D(L, "%3d: Found %p\n", i, PL_op));
+ add_conditional(op, SvTRUE(TOPs) ? 2 : 1);
+ }
+
+ av_clear(conds);
+ }
+ else
+ {
+ /* We might get here in an eval for example, where there
+ * hasn't been a chance to hack the op_seq numbers
+ * first. We've wasted a bit of effort, but it's no
+ * problem.
+ */
+#if 0
+ int i;
+
+ svdump(Pending_conditionals);
+ for (i = 0; i < ch_sz; i++)
+ {
+ printf("%o:", ch[i] & 0xff);
+ }
+ op_dump(PL_op);
+ Perl_croak(aTHX_ "No pending conditional found at %p, %d: %p\n",
+ PL_op, PL_op->op_seq, sv);
+#endif
+ }
+ }
+
+ switch (PL_op->op_type)
+ {
+ case OP_SETSTATE:
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ {
+#if CAN_PROFILE
+ /* lapsed = Profiling && PL_curcop != cop ? elapsed() : -1; */
+ lapsed = collecting(Time) ? elapsed() : -1;
+#endif
+
+ if (collecting(Statement))
+ {
+ char *ch = get_key(PL_op);
+ count = hv_fetch(Statements, ch, ch_sz, 1);
+ c = SvTRUE(*count) ? SvIV(*count) + 1 : 1;
+ sv_setiv(*count, c);
+
+ NDEB(op_dump(PL_op));
+ }
+
+#if CAN_PROFILE
+ if (lapsed > -1)
+ {
+ if (cop)
+ {
+ char *ch = get_key((OP *)cop);
+ count = hv_fetch(Times, ch, ch_sz, 1);
+ c = (SvTRUE(*count) ? SvIV(*count) : 0) +
+#if 0
+ Profiling == 1 ? cpu() : elapsed();
+#else
+ lapsed;
+#endif
+ sv_setiv(*count, c);
+ }
+ elapsed(); /* reset the timer */
+ cop = PL_curcop;
+ }
+#endif
+ break;
+ }
+
+ case OP_COND_EXPR:
+ {
+ if (collecting(Branch))
+ {
+ dSP;
+ int val = SvTRUE(TOPs);
+ add_branch(PL_op, !val);
+ }
+ break;
+ }
+
+ case OP_AND:
+ case OP_OR:
+ {
+ /*
+ * For OP_AND, if the first operand is false, we have
+ * short circuited the second, otherwise the value of
+ * the and op is the value of the second operand.
+ *
+ * For OP_OR, if the first operand is true, we have
+ * short circuited the second, otherwise the value of
+ * the and op is the value of the second operand.
+ *
+ * We check the value of the first operand by simply
+ * looking on the stack. To check the second operand it
+ * is necessary to note the location of the next op
+ * after this logop. When we get there, we look at the
+ * stack and store the coverage information indexed to
+ * this op.
+ *
+ * The information about the next op is stored in the
+ * Pending_conditionals array which we have to iterate
+ * through later. collect_conditional tells how many
+ * conditionals are in the array. When we find one we
+ * leave it in the array but change the data so we don't
+ * match again. Then, when collect_conditional is zero
+ * Pending_conditionals is emptied. This might not be
+ * the speed win I had hoped for.
+ */
+
+ if (!collecting(Condition))
+ break;
+
+ if (cLOGOP->op_first->op_type == OP_ITER)
+ {
+ /* loop - ignore it */
+ }
+ else
+ {
+ dSP;
+ int first_val = SvTRUE(TOPs);
+ if (PL_op->op_type == OP_AND && first_val ||
+ PL_op->op_type == OP_OR && !first_val)
+ {
+ char *ch;
+ AV *conds;
+ SV **tmp,
+ *cond;
+
+ ch = get_key(PL_op->op_next);
+ tmp = hv_fetch(Pending_conditionals, ch, ch_sz, 1);
+ if (SvROK(*tmp))
+ conds = (AV *)SvRV(*tmp);
+ else
+ *tmp = newRV_inc((SV*) (conds = newAV()));
+
+ cond = newSViv((IV)PL_op);
+ av_push(conds, cond);
+
+ /* condition_waiting_set(PL_op->op_next); */
+
+ NDEB(D(L, "Adding conditional %p to %d, making %d\n",
+ PL_op->op_next, PL_op->op_next->op_seq,
+ av_len(conds) + 1));
+ NDEB(svdump(Pending_conditionals));
+ NDEB(op_dump(PL_op));
+ NDEB(op_dump(PL_op->op_next));
+
+ }
+ else
+ {
+ add_conditional(PL_op, 0);
+ }
+ }
+ break;
+ }
+
+ default:
}
- PERL_ASYNC_CHECK();
}
TAINT_NOT;
return 0;
}
-static int
-runops_orig(pTHX)
+static int runops_orig(pTHX)
{
- /* fprintf(stderr, "runops_orig\n"); */
+ NDEB(D(L, "runops_orig\n"));
+
while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)))
{
PERL_ASYNC_CHECK();
@@ -173,40 +531,101 @@ MODULE = Devel::Cover PACKAGE = Devel::Cover
PROTOTYPES: ENABLE
void
-set_cover(flag)
- int flag
+set_criteria(flag)
+ unsigned flag
PPCODE:
/* fprintf(stderr, "Cover set to %d\n", flag); */
- PL_runops = ((covering = flag) || profiling)
- ? runops_cover
- : runops_orig;
+ PL_runops = (Covering = flag) ? runops_cover : runops_orig;
void
-set_profile(flag)
- int flag
+add_criteria(flag)
+ unsigned flag
PPCODE:
- /* fprintf(stderr, "Cover set to %d\n", flag); */
- PL_runops = ((profiling = flag) || covering)
- ? runops_cover
- : runops_orig;
+ PL_runops = (Covering |= flag) ? runops_cover : runops_orig;
-SV *
-coverage()
+void
+remove_criteria(flag)
+ unsigned flag
+ PPCODE:
+ PL_runops = (Covering &= ~flag) ? runops_cover : runops_orig;
+
+unsigned
+get_criteria()
CODE:
- ST(0) = sv_newmortal();
- if (cover_hv)
- sv_setsv(ST(0), newRV_inc((SV*) cover_hv));
- else
- ST(0) = &PL_sv_undef;
+ RETVAL = Covering;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_none()
+ CODE:
+ RETVAL = None;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_statement()
+ CODE:
+ RETVAL = Statement;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_branch()
+ CODE:
+ RETVAL = Branch;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_condition()
+ CODE:
+ RETVAL = Condition;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_path()
+ CODE:
+ RETVAL = Path;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_pod()
+ CODE:
+ RETVAL = Pod;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_time()
+ CODE:
+ RETVAL = Time;
+ OUTPUT:
+ RETVAL
+
+unsigned
+coverage_all()
+ CODE:
+ RETVAL = All;
+ OUTPUT:
+ RETVAL
SV *
-profiles()
+coverage()
CODE:
ST(0) = sv_newmortal();
- if (profile_hv)
- sv_setsv(ST(0), newRV_inc((SV*) profile_hv));
+ if (Cover_hv)
+ sv_setsv(ST(0), newRV_inc((SV*) Cover_hv));
else
ST(0) = &PL_sv_undef;
+void
+reset_op_seq(op)
+ void *op
+ PPCODE:
+ walk_reset_op_seq((OP *) op);
+
BOOT:
- PL_runops = runops_cover;
+ PL_runops = runops_orig;
View
53 MANIFEST
@@ -4,21 +4,46 @@ CHANGES
TODO
BUGS
Makefile.PL
-Cover.pm
+lib/Devel/Cover.pm
Cover.xs
-Cover/DB.pm
-Cover/Op.pm
-Cover/Criterion.pm
-Cover/Statement.pm
-Cover/Condition.pm
-Cover/Pod.pm
-Cover/Time.pm
-Cover/DB/File.pm
-t/Compare.pm
-t/t1.t
-t/T1.pm
-t/t2.t
+lib/Devel/Cover/DB.pm
+lib/Devel/Cover/Op.pm
+lib/Devel/Cover/Criterion.pm
+lib/Devel/Cover/Statement.pm
+lib/Devel/Cover/Branch.pm
+lib/Devel/Cover/Condition.pm
+lib/Devel/Cover/Pod.pm
+lib/Devel/Cover/Time.pm
+lib/Devel/Cover/DB/File.pm
+lib/Devel/Cover/Test.pm
+lib/Devel/Cover/Report/Text.pm
+lib/Devel/Cover/Report/Html.pm
cover
gcov2perl
-Cover/Tutorial.pod
+create_gold
+templates/html/colours
+templates/html/file
+templates/html/html
+templates/html/summary
+templates/html/branches
+templates/html/conditions
+tests/t0
+tests/t1
+tests/t2
+tests/eval1
+tests/module1
+tests/module2
+tests/cond_and
+tests/cond_or
+tests/Module1.pm
+tests/Module2.pm
+test_output/cover/t0
+test_output/cover/t1
+test_output/cover/t2
+test_output/cover/eval1
+test_output/cover/module1
+test_output/cover/module2
+test_output/cover/cond_and
+test_output/cover/cond_or
+lib/Devel/Cover/Tutorial.pod
session.vim
View
187 Makefile.PL
@@ -12,12 +12,14 @@ require 5.6.1;
use strict;
use warnings;
+use Cwd;
+
use ExtUtils::MakeMaker;
$| = 1;
-my $Version = "0.14";
-my $Date = "28th February 2002";
+my $Version = "0.15";
+my $Date = "5th September 2002";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
@@ -27,11 +29,17 @@ my $Perlbug = join " ", map { / / ? "'$_'" : $_ } @perlbug;
open M, "MANIFEST" or die "Cannot open MANIFEST: $!";
-my @files = map { split } <M>, "Cover/Inc.pm";
+my @files = map { split } <M>, "lib/Devel/Cover/Inc.pm";
my @versions = grep { $_ ne "README" && $_ ne "Makefile.PL" } @files;
close M or die "Cannot close MANIFEST: $!";
-open I, ">Cover/Inc.pm" or die "Cannot open Cover/Inc.pm: $!";
+my $base = getcwd;
+
+my %inc = map { $_ => 1 } @INC;
+my @inc = sort keys %inc;
+
+open I, ">lib/Devel/Cover/Inc.pm"
+ or die "Cannot open lib/Devel/Cover/Inc.pm: $!";
print I <<"EOI";
# Copyright 2001-2002, Paul Johnson (pjcj\@cpan.org)
@@ -48,50 +56,118 @@ use strict;
use warnings;
our \$VERSION = "$Version";
-our \@Inc = qw( @INC );
+our \$Perl = "$^X";
+our \$Base = "$base";
+our \@Inc = qw( @inc );
1
EOI
-close I or die "Cannot close Cover/Inc.pm: $!";
+close I or die "Cannot close lib/Devel/Cover/Inc.pm: $!";
-$ExtUtils::MakeMaker::Verbose = 0;
+print "Writing tests ........ ";
-WriteMakefile
-(
- NAME => "Devel::Cover",
- VERSION => $Version,
- AUTHOR => 'Paul Johnson (pjcj@cpan.org)',
- ABSTRACT => "Code coverage metrics for Perl",
- DIR => [],
- PM => { map {($_ => '$(INST_LIBDIR)/' . $_)}
- grep { /\.p(m|od)/ } @files },
- dist => { COMPRESS => "gzip --best --force" },
- clean => { FILES => join " ", map { "$_.version" } @versions },
- depend => { distdir => "@files" },
-);
+unless (-d "t")
+{
+ mkdir "t" or die "Cannot mkdir t: $!";
+}
+
+opendir D, "tests" or die "Cannot opendir tests: $!";
+for my $t (readdir D)
+{
+ next unless -f "tests/$t";
+ next if $t =~ /\.(pm|version|org|bak)$/;
+ next if $t =~ /~$/;
+ open T, ">t/a$t.t" or die "Cannot open t/a$t.t: $!";
+ print T <<EOT;
+#!$^X
+
+# Copyright 2002, Paul Johnson (pjcj\@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+use strict;
+use warnings;
+
+use lib "$base/lib";
+use lib "$base/blib/lib";
+use lib "$base/blib/arch";
+use lib "$base/t";
+
+use Devel::Cover::Test $Version;
+
+my \$test = Devel::Cover::Test->new("$t");
+\$test->run_test
+EOT
+ close T or die "Cannot open t/a$t.t: $!";
+}
+closedir D or die "Cannot closedir tests: $!";
+
+print "done\n\n";
+
+my $e;
+
+print "checking for Template.pm version 2.00 ........ ";
+
+$e = <<EOM;
+
+Template.pm 2.00 is required to run the HTML backend to cover. You will
+not be able to generate HTML output until you install the Template
+Toolkit, available from CPAN. In the meantime you may continue to use
+the rest of Devel::Cover.
+
+EOM
+
+eval "use Template";
+if (my $m = $INC{"Template.pm"})
+{
+ my $v = eval { no warnings; $Template::VERSION };
+ print $v < 2.00 ? "$v\n\n$e\n" : "$v $m\n";
+}
+else
+{
+ print "not found\n\n$e\n";
+}
-print "\n";
print "checking for Pod::Coverage.pm version 0.06 ........ ";
-my $e = <<EOM;
+$e = <<EOM;
Pod::Coverage.pm 0.06 is required to do pod coverage. This will tell
you how well you have documented your modules. Pod coverage will be
unavailable until you install this module, available from CPAN. In the
-meantime, you may continue to use the rest of Devel::Cover.pm.
+meantime, you may continue to use the rest of Devel::Cover.
EOM
eval "use Pod::Coverage";
if (my $m = $INC{"Pod/Coverage.pm"})
{
- my $v = eval { no warnings; $Pod::Coverage::VERSION };
- print $v < 0.06 ? "$v\n\n$e\n" : "$v $m\n";
+ my $v = eval { no warnings; $Pod::Coverage::VERSION };
+ print $v < 0.06 ? "$v\n\n$e\n" : "$v $m\n";
}
else
{
- print "not found\n\n$e\n";
+ print "not found\n\n$e\n";
}
+$ExtUtils::MakeMaker::Verbose = 0;
+
+WriteMakefile
+(
+ NAME => "Devel::Cover",
+ VERSION => $Version,
+ AUTHOR => 'Paul Johnson (pjcj@cpan.org)',
+ ABSTRACT => "Code coverage metrics for Perl",
+ DIR => [],
+ EXE_FILES => [ "cover", "gcov2perl" ],
+ dist => { COMPRESS => "gzip --best --force" },
+ clean => { FILES => join " ", map { "$_.version" } @versions },
+ depend => { distdir => "@files" },
+);
+
+print "\n";
print <<EOM if 0;
--------------------------------------------------------------------------------
@@ -109,40 +185,69 @@ README file, or send mail to me directly.
EOM
+sub MY::libscan
+{
+ my ($self, $path) = @_;
+ (my $p = $path) =~ s/^\$\(INST_LIB\)/lib/; # 5.6.1
+ # print "$path $p\n";
+ my $wanted;
+ for my $f (@files)
+ {
+ last if $wanted = $p =~ /$f$/;
+ }
+ $wanted && $path;
+}
+
sub MY::postamble
{
- qq[
+ qq[
SET_VERSION = \$(PERL) -pi.version \\
- -e 's/(^\\s*(?:our\\s+)\\\$\$VERSION = ")\\d+\\.\\d+(";)/\$\${1}$Version\$\$2/;' \\
- -e 's/(Version )\\d+\\.\\d+( - ).*/\$\${1}$Version\$\${2}$Date/;' \\
- -e 's/(^\\s*use Devel::Cover(?:::\\w+)*\\s+)\\d+\\.\\d+/\$\${1}$Version/;'
+ -e 's/(^\\s*(?:our\\s+)\\\$\$VERSION = ")\\d+\\.\\d+(";)/\$\${1}$Version\$\$2/;' \\
+ -e 's/(Version )\\d+\\.\\d+( - ).*/\$\${1}$Version\$\${2}$Date/;' \\
+ -e 's/(^\\s*use Devel::Cover(?:::\\w+)*\\s+)\\d+\\.\\d+/\$\${1}$Version/;'
tags : @files
\t ptags @files
@versions : Makefile.PL
\t \$(SET_VERSION) @versions
-README : Cover.pm
-\t TERMCAP= COLUMNS=80 pod2text Cover.pm | \\
- \$(PERL) -n \\
- -e 'print if (/NAME/ ... /^[A-Z ]+\$\$/) =~ /^\\d+\$\$/;' \\
- -e 'print if (/DESCRIPTION/ ... /^[A-Z ]+\$\$/) =~ /^\\d+\$\$/;' \\
- > README
+README : lib/Devel/Cover.pm
+\t TERMCAP= COLUMNS=80 pod2text lib/Devel/Cover.pm | \\
+ \$(PERL) -n \\
+ -e 'print if (/NAME/ ... /^[A-Z ]+\$\$/) =~ /^\\d+\$\$/;' \\
+ -e 'print if (/DESCRIPTION/ ... /^[A-Z ]+\$\$/) =~ /^\\d+\$\$/;' \\
+ > README
ppm : ppd pure_all
\t tar cf Devel-Cover.tar blib
\t gzip --best --force Devel-Cover.tar
\t \$(PERL) -pi.bak \\
- -e 's/(OS NAME=")[^"]*/\$\$1MSWin32/;' \\
- -e 's/(ARCHITECTURE NAME=")[^"]*/\$\$1MSWin32-x86-multi-thread/;' \\
- -e 's/(CODEBASE HREF=")[^"]*/\$\$1Gedcom.tar.gz/;' \\
- Devel-Cover.ppd
+ -e 's/(OS NAME=")[^"]*/\$\$1MSWin32/;' \\
+ -e 's/(ARCHITECTURE NAME=")[^"]*/\$\$1MSWin32-x86-multi-thread/;' \\
+ -e 's/(CODEBASE HREF=")[^"]*/\$\$1Gedcom.tar.gz/;' \\
+ Devel-Cover.ppd
+
+run : pure_all
+\t \$(PERL) -Mblib -MDevel::Cover=-ignore,blib,-merge,0 tests/\$(TEST) && \\
+ \$(PERL) -Mblib cover -report text \\
+ > \$(TEST).out && \\
+ gvim -d -geom 88x60+104+0 \$(TEST).out
+
+diff : pure_all
+\t \$(PERL) -Mblib -MDevel::Cover=-ignore,blib,-merge,0 tests/\$(TEST) && \\
+ \$(PERL) -Mblib cover -report text \\
+ -coverage statement -coverage branch -coverage condition \\
+ > \$(TEST).out && \\
+ gvim -d -geom 185x83+0+0 -font 8x13 test_output/cover/\$(TEST) \$(TEST).out
+
+gold : pure_all
+\t \$(PERL) create_gold \$(TEST)
ok :
\t \@$Perlbug -okay || echo "Please send your report manually to $Author"
nok :
\t \@$Perlbug -nokay || echo "Please send your report manually to $Author"
- ]
+ ]
}
View
19 README
@@ -13,22 +13,29 @@ DESCRIPTION
The cover program can be used to generate coverage reports.
- At the moment, only statement, pod and time coverage information is
- reported. Condition coverage data is available, though not accurate at
- the moment. Statement coverage data should be reasonable, although there
- may be some statements which are no reported. Pod coverage comes from
- Pod::Coverage. Coverage data for other metrics are collected, but not
- reported. Coverage data for some metrics are not yet collected.
+ Statement, branch, condition, pod and time coverage information is
+ reported. Statement coverage data should be reasonable, although there
+ may be some statements which are not reported. Branch coverage data
+ should be mostly accurate too. Condition coverage data are only
+ available for && and || ops. These data should be mostly accurate,
+ although not always what one might initially expect. Pod coverage comes
+ from Pod::Coverage. Coverage data for path coverage are not yet
+ collected.
The gcov2perl program can be used to convert gcov files to Devel::Cover
databases.
You may find that the results don't match your expectations. I would
imagine that at least one of them is wrong.
+ THe most appropriate mailing list on which to discuss this module would
+ be perl-qa. Discussion has migrated there from perl-qa-metrics which is
+ now defunct. http://lists.perl.org/showlist.cgi?name=perl-qa
+
Requirements:
Perl 5.6.1 or 5.7.1.
The ability to compile XS extensions.
Pod::Coverage if you want pod coverage.
+ Template Toolkit 2 if you want HTML output.
View
11 TODO
@@ -1,8 +1,13 @@
+- Condition coverage of xor
+- Indicate how to increase coverage?
+- Make the HTML output nicer
- Collect data for path coverage.
-- Parse for branch and condition coverage.
- Tests.
- Documentation.
+- Profiling and speedups.
- BEGIN and END blocks.
+ Code in modules without subs. Requires callbacks from perl?
+- Move away from Data::Dumper. To?
- Work with memoize.
-- Code in modules without subs.
-- Use B::Utils?
+- Fix up Devel::Cover::Op
+- See if the XS code leaks, and fix it if it does.
View
344 cover
@@ -12,266 +12,99 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.14";
+our $VERSION = "0.15";
-use Devel::Cover::DB 0.14;
-use Devel::Cover::Statement 0.14;
-use Devel::Cover::Condition 0.14;
-use Devel::Cover::Pod 0.14;
-use Devel::Cover::Time 0.14;
+use Devel::Cover::DB 0.15;
use Getopt::Long;
-BEGIN { eval "use Pod::Coverage" } # We'll use this if it is available.
+
+use Pod::Usage;
my $Options =
{
- branch => 0,
- condition => 0,
- details => 0,
- html => 1,
- path => 0,
- pod => $INC{"Pod/Coverage.pm"},
- single_file => 0,
- statement => 1,
- summary => 1,
- time => 1,
- total => 1,
+ coverage => [],
+ file => [],
+ option => [],
+ report => "",
+ summary => 1,
};
-sub print_html_top
+sub get_options
{
- my ($FH, $title) = @_;
-
- print $FH <<"EOH";
-<?xml version="1.0" encoding="utf-8"?>
-<!DOCTYPE html
- PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN"
- "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
-<body bgcolor="#ffffad" text="#000000">
- <title> $title </title>
-</head>
-<body>
-EOH
+ die "Bad option" unless
+ GetOptions($Options, # Store the options in the Options hash.
+ "write:s" => sub
+ {
+ @$Options{qw(write summary)} = ($_[1], 0)
+ },
+ qw(
+ coverage=s
+ help|h!
+ file=s
+ info|i!
+ option=s
+ report=s
+ summary!
+ version|v!
+ ));
}
-sub print_html_bottom
+sub main
{
- my ($FH) = @_;
-
- print $FH <<"EOH";
-</body>
-</html>
-EOH
-}
+ get_options;
-sub print_html
-{
- my ($db, $dbname, $single_file) = @_;
-
- print "Writing HTML to $dbname/$dbname.html\n";
-
- open my $FH, ">$dbname/$dbname.html"
- or die "Cannot open $dbname/$dbname.html: $!\n";
-
- print_html_top($FH, $dbname);
- print $FH <<"EOH";
- <a name="Total">
- <h1> Coverage report for $dbname </h1>
- </a>
- <table border="2">
- <tr align="RIGHT" valign="CENTER">
- <th align="LEFT"> File </th>
-EOH
- print $FH " <th> $_ </th>\n" for $db->all_criteria_short;
- print $FH " </tr>\n";
- for my $file (grep($_ ne "Total", sort keys %{$db->{summary}}), "Total")
+ my $format = "Devel::Cover::Report::\u$Options->{report}";
+ if (length $Options->{report})
{
- my $fn = "";
- unless ($single_file)
+ eval ("use $format");
+ if ($@)
{
- ($fn = $file) =~ s/\W/-/g;
- $fn .= ".html"
- }
-
- print $FH qq( <tr align="RIGHT" valign="CENTER">\n);
- print $FH -e $file
- ? qq( <td align="LEFT"> <a href="$fn#$file">$file</a> </td>\n)
- : qq( <td align="LEFT"> $file </td>\n);
-
- my $part = $db->{summary}{$file};
- for my $criterion ($db->all_criteria)
- {
- my $pc = ($Options->{$criterion} && exists $part->{$criterion})
- ? sprintf "%6.2f", $part->{$criterion}{percentage}
- : "n/a";
-
- my $bg = "";
- if ($pc ne "n/a")
- {
- my $c;
- $c = $pc * 2.55;
- $c = 255 if $c > 255;
- if ($criterion eq "time")
- {
- $c = 255 - $c;
- $c = 255 if $file eq "Total";
- }
- $bg = sprintf ' bgcolor="#ff%02x00"', $c;
- }
- print $FH " <td$bg> $pc </td>\n";
+ print "Error: $Options->{report} ",
+ "is not a recognised output format\n\n$@";
+ exit 1;
}
}
- print $FH " </table>\n";
- my (@files) = @ARGV;
- my $cover = $db->cover;
+ print "$0 version $VERSION\n" and exit 0 if $Options->{version};
+ pod2usage(-exitval => 0, -verbose => 0) if $Options->{help};
+ pod2usage(-exitval => 0, -verbose => 2) if $Options->{info};
- # use Data::Dumper;
- # $Data::Dumper::Indent = 1;
- # print Dumper $cover;
+ my $dbname = shift @ARGV || "cover_db";
- @files = sort $cover->items unless @files;
+ print "Reading database from $dbname\n";
+ my $db = Devel::Cover::DB->new(db => $dbname);
- for my $file (@files)
+ for my $merge (@ARGV)
{
- (my $fn = $file) =~ s/\W/-/g;
- my $FF;
- if ($single_file)
- {
- $FF = $FH;
- }
- else
- {
- open $FF, ">$dbname/$fn.html"
- or die "Cannot open $dbname/$fn.html: $!\n";
- print_html_top($FF, $file);
- }
-
- print $FF qq( <h2> <a name="$file"> $file </a></h2>\n);
- my $f = $cover->file($file);
-
- open F, $file or warn("Unable to open $file: $!\n"), next;
-
- print $FF <<"EOH";
- <table border="0">
- <tr align="CENTER" valign="CENTER">
- <th> &nbsp; </th>
-EOH
- my %cr; @cr{$db->criteria} = $db->criteria_short;
- for my $c ($db->criteria)
- {
- print $FF " <th> $cr{$c} </th>\n" if $Options->{$c};
- }
- print $FF <<"EOH";
- <th> Text </th>
- </tr>
-EOH
- LINE: while (defined(my $l = <F>))
- {
- chomp $l;
- my $n = $.;
-
- my %criteria;
- for my $c ($db->criteria)
- {
- next unless $Options->{$c};
- my $criterion = $f->$c();
- $criteria{$c} = $criterion->location($n) if $criterion;
- }
-
- my $more = 1;
- while ($more)
- {
- print $FF <<"EOH";
- <tr align="RIGHT" valign="CENTER">
- <td bgcolor="#ffffc0"> $n </td>
-EOH
-
- my $error = 0;
- $more = 0;
- for my $c ($db->criteria)
- {
- next unless $Options->{$c};
- my $o = shift @{$criteria{$c}};
- $more ||= @{$criteria{$c}};
- my $value = $o
- ? ($c =~ /statement|pod|time/)
- ? $o->covered
- : $o->percentage
- : "&nbsp";
- my $bg = $o
- ? ' bgcolor="#' . ($o->error ? 'ff0000"' : '00ff00"')
- : "";
- print $FF " <td$bg> $value </td>\n";
- $error ||= $o->error if $o;
- }
-
- my $bg = $error ? ' bgcolor="#ff0000"' : "";
-
- print $FF <<"EOH";
- <td$bg align="LEFT" valign="CENTER"> <pre> $l </pre> </td>
- </tr>
-EOH
-
- last LINE if $l =~ /^__(END|DATA)__/;
- $n = $l = "&nbsp;";
- }
- }
- print $FF qq( </table>\n);
- close F or die "Unable to close $file: $!";
- unless ($single_file)
- {
- print_html_bottom($FF);
- close $FF or die "Cannot close $dbname/$fn.html: $!\n";
- }
+ print "Merging database from $merge\n";
+ my $mdb = Devel::Cover::DB->new(db => $merge);
+ $db->merge($mdb);
}
- print_html_bottom($FH);
-
- close $FH or die "Cannot close $dbname/$dbname.html: $!\n";
+ if (exists $Options->{write})
+ {
+ $dbname = $Options->{write} if length $Options->{write};
+ print "Writing database to $dbname\n";
+ $db->write($dbname);
+ }
- # $db->print_summary;
- # $db->print_details;
-}
+ return unless $Options->{summary} || $Options->{report};
-sub get_options
-{
- die "Bad option" unless
- GetOptions($Options, # Store the options in the Options hash.
- qw(
- branch!
- condition!
- details!
- help|h!
- html!
- info|i!
- path|i!
- pod|i!
- single_file!
- statement!
- summary!
- time!
- total!
- version|v!
- ));
- print "$0 version $VERSION\n" and exit 0 if $Options->{version};
-}
+ $Options->{coverage} = [ $db->collected ] unless @{$Options->{coverage}};
+ $Options->{show} = { map { $_ => 1 } @{$Options->{coverage}} };
+ $Options->{show}{total} = 1 if keys %{$Options->{show}};
-sub main
-{
- get_options;
+ $db->calculate_summary(map { $_ => 1 } @{$Options->{coverage}});
- my $dbname = shift @ARGV;
+ print "\n\n";
- my $db = Devel::Cover::DB->new(db => $dbname);
+ $db->print_summary(@{$Options->{coverage}}) if $Options->{summary};
- $db->calculate_summary(map { $_ => $Options->{$_} } $db->criteria);
+ return unless length $Options->{report};
- print_html($db, $dbname, $Options->{single_file}) if $Options->{html};
+ @{$Options->{file}} = sort $db->cover->items unless @{$Options->{file}};
- $db->print_summary if $Options->{summary};
- $db->print_details if $Options->{details};
+ $format->report($db, $Options)
}
main
@@ -284,52 +117,75 @@ cover - report coverage statistics
=head1 SYNOPSIS
- cover -h -i -v -summary -details -html coverage_database
+ cover -help -info -version -summary
+ -report report_format -option option
+ -file filename -coverage criterion -write [db]
+ coverage_database [coverage_database ...]
=head1 DESCRIPTION
Report coverage statistics in a variety of formats.
-The following reports are available:
+The summary option produces a short textual summary. Other reports are
+available by using the report option.
- summary - short textual summary
- details - detailed textual summary
- html - detailed HTML reports
+The following reports are currently available:
-By default, the summary and HTML reports are generated.
+ text - detailed textual summary
+ html - detailed HTML reports
=head1 OPTIONS
The following command line options are supported:
- -summary - give summary report
- -details - give detailed report
- -html - give HTML reports
- -single_file - give an HTML in a single file
+ -summary - give summary report (default on)
+ -report report_format - report format required (default none)
+ -option - options for report
+
+ -file filename - only report on the file (default all)
+ -write [db] - write the merged database (default off)
+
+ -coverage criterion - report on criterion (default all available)
+
+ -h -help - show help
+ -i -info - show documentation
+ -v -version - show version
+
+=head1 DETAILS
+
+Any number of coverage databases may be specified on the command line.
+These databases will be merged and the reports will be based on the
+merged information. If no databases are specified the default database
+(cover_db) will be used.
+
+The -write option will write out the merged database. If no name is
+given for the new database, the first database read in will be
+overwritten. When this option is used no reports are generated by
+default.
- -h -help - show help
- -i -info - show documentation
- -v -version - show version
+Specify -file options to report on specific files. Specify -coverage
+options to report on specific criteria. By default all available
+information on all criteria in all files will be reported.
=head1 EXIT STATUS
The following exit values are returned:
-0 All reports were generated successfully.
+0 All operaions were completed successfully.
>0 An error occurred.
=head1 SEE ALSO
- Dvel::Cover
+ Devel::Cover
=head1 BUGS
Huh?
=head1 VERSION
-Version 0.14 - 28th February 2002
+Version 0.15 - 5th September 2002
=head1 LICENCE
View
41 create_gold
@@ -0,0 +1,41 @@
+#!/usr/local/bin/perl
+
+# Copyright 2002, Paul Johnson (pjcj@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+require 5.6.1;
+
+use strict;
+use warnings;
+
+our $VERSION = "0.15";
+
+use blib;
+
+use Devel::Cover::Test 0.15;
+
+my @tests = @ARGV;
+
+unless (@tests)
+{
+ opendir D, "tests" or die "Cannot opendir tests: $!";
+ for my $t (readdir D)
+ {
+ next unless -f "tests/$t";
+ next if $t =~ /\.(pm|version|org|bak)$/;
+ next if $t =~ /~$/;
+
+ push @tests, $t;
+ }
+ closedir D or die "Cannot closedir tests: $!";
+}
+
+for my $test (@tests)
+{
+ my $t = Devel::Cover::Test->new($test);
+ $t->create_gold;
+}
View
11 gcov2perl
@@ -12,11 +12,12 @@ require 5.6.1;
use strict;
use warnings;
-use Devel::Cover::DB 0.14;
+our $VERSION = "0.15";
-our $VERSION = "0.14";
+use Devel::Cover::DB 0.15;
use Getopt::Long;
+use Pod::Usage;
my $Options =
{
@@ -38,6 +39,8 @@ sub get_options
version|v!
));
print "$0 version $VERSION\n" and exit 0 if $Options->{version};
+ pod2usage(-exitval => 0, -verbose => 0) if $Options->{help};
+ pod2usage(-exitval => 0, -verbose => 2) if $Options->{info};
}
sub add_cover
@@ -54,7 +57,7 @@ sub add_cover
s/\s+//g;
$_ = 0 if $_ eq "######";
next if !length || /\D/;
- $cover->{$f}{statement}{$.} = [[$_]];
+ $cover->{$f}{statement}{$.} = [[[$_]]];
}
close F or die "Can't open $file: $!\n";
}
@@ -125,7 +128,7 @@ Huh?
=head1 VERSION
-Version 0.14 - 28th February 2002
+Version 0.15 - 5th September 2002
=head1 LICENCE
View
585 lib/Devel/Cover.pm
@@ -0,0 +1,585 @@
+# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+
+# This software is free. It is licensed under the same terms as Perl itself.
+
+# The latest version of this software should be available from my homepage:
+# http://www.pjcj.net
+
+package Devel::Cover;
+
+use strict;
+use warnings;
+
+our @ISA = qw( DynaLoader );
+our $VERSION = "0.15";
+
+use DynaLoader ();
+
+use Devel::Cover::DB 0.15;
+use Devel::Cover::Inc 0.15;
+
+use B qw( class ppname main_cv main_start main_root walksymtable OPf_KIDS );
+use B::Debug;
+use B::Deparse;
+
+use Cwd ();
+
+BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available.
+
+my $DB = "cover_db"; # DB name.
+my $Indent = 0; # Data::Dumper indent.
+my $Merge = 1; # Merge databases.
+
+my @Ignore; # Packages to ignore.
+my @Inc; # Original @INC to ignore.
+my @Select; # Packages to select.
+
+my $Pod = $INC{"Pod/Coverage.pm"}; # Do pod coverage.
+
+my $Summary = 1; # Output coverage summary.
+
+my @Cvs; # All the Cvs we want to cover.
+my $Cv; # Cv we are looking in.
+
+my $Coverage; # Raw coverage data.
+my $Cover; # Coverage data.
+
+my %Criteria; # Names of coverage criteria.
+my %Coverage; # Coverage criteria to collect.
+
+my $Cwd = Cwd::cwd(); # Where we start from.
+
+BEGIN { @Inc = @Devel::Cover::Inc::Inc }
+# BEGIN { $^P = 0x02 | 0x04 | 0x100 }
+BEGIN { $^P = 0x04 | 0x100 }
+
+CHECK
+{
+ check_files();
+
+ # reset_op_seq(main_root);
+ # reset_op_seq($_->ROOT) for @Cvs;
+
+ set_coverage(keys %Coverage);
+
+ my @coverage = get_coverage();
+ my $last = pop @coverage;
+ print __PACKAGE__, " $VERSION: Collecting coverage data for ",
+ join(", ", @coverage),
+ @coverage ? " and " : "",
+ "$last.\n",
+ "Selecting packages matching:", join("\n ", "", @Select), "\n",
+ "Ignoring packages matching:", join("\n ", "", @Ignore), "\n",
+ "Ignoring packages in:", join("\n ", "", @Inc), "\n";
+}
+
+END { report() }
+
+sub import
+{
+ my $class = shift;
+
+ # print __PACKAGE__, ": Parsing options from [@_]\n";
+
+ @Inc = () if "@_" =~ /-inc /;
+ while (@_)
+ {
+ local $_ = shift;
+ /^-db/ && do { $DB = shift; next };
+ /^-indent/ && do { $Indent = shift; next };
+ /^-merge/ && do { $Merge = shift; next };
+ /^-summary/ && do { $Summary = shift; next };
+ /^-coverage/ &&
+ do { $Coverage{+shift} = 1 while @_ && $_[0] !~ /^[-+]/; next };
+ /^-ignore/ &&
+ do { push @Ignore, shift while @_ && $_[0] !~ /^[-+]/; next };
+ /^[-+]inc/ &&
+ do { push @Inc, shift while @_ && $_[0] !~ /^[-+]/; next };
+ /^-select/ &&
+ do { push @Select, shift while @_ && $_[0] !~ /^[-+]/; next };
+ warn __PACKAGE__ . ": Unknown option $_ ignored\n";
+ }
+
+ for my $c (Devel::Cover::DB->new->criteria)
+ {
+ my $func = "coverage_$c";
+ no strict "refs";
+ $Criteria{$c} = $func->();
+ }
+
+ %Coverage = map { $_ => 1 } qw(statement branch condition time)
+ unless keys %Coverage;
+}
+
+sub cover_names_to_val
+{
+ my $val = 0;
+ for my $c (@_)
+ {
+ if (exists $Criteria{$c})
+ {
+ $val |= $Criteria{$c};
+ }
+ elsif ($c eq "all" || $c eq "none")
+ {
+ my $func = "coverage_$c";
+ no strict "refs";
+ $val |= $func->();
+ }
+ else
+ {
+ warn __PACKAGE__ . qq(: Unknown coverage criterion "$c" ignored.\n);
+ }
+ }
+ $val;
+}
+
+sub set_coverage
+{
+ set_criteria(cover_names_to_val(@_));
+}
+
+sub add_coverage
+{
+ add_criteria(cover_names_to_val(@_));
+}
+
+sub remove_coverage
+{
+ remove_criteria(cover_names_to_val(@_));
+}
+
+sub get_coverage
+{
+ return unless defined wantarray;
+ my @names;
+ my $val = get_criteria();
+ for my $c (sort keys %Criteria)
+ {
+ push @names, $c if $val & $Criteria{$c};
+ }
+ return wantarray ? @names : "@names";
+}
+
+my ($F, $L) = ("", 0);
+
+sub get_location
+{
+ my ($op) = @_;
+
+ $F = $op->file;
+ $L = $op->line;
+
+ # If there's an eval, get the real filename. Enabled from $^P & 0x100.
+
+ ($F, $L) = ($1, $2) if $F =~ /^\(eval \d+\)\[(.*):(\d+)\]/;
+
+ $F =~ s/ \(autosplit into .*\)$//;
+ $F =~ s/^$Cwd\///;
+}
+
+sub use_file
+{
+ my ($file) = @_;
+ $file = $1 if $file =~ /^\(eval \d+\)\[(.*):\d+\]/;
+ $file =~ s/ \(autosplit into .*\)$//;
+ my $files = \%Devel::Cover::Files;
+ return $files->{$file} if exists $files->{$file};
+ for (@Select) { return $files->{$file} = 1 if $file =~ /$_/ }
+ for (@Ignore) { return $files->{$file} = 0 if $file =~ /$_/ }
+ for (@Inc) { return $files->{$file} = 0 if $file =~ /^\Q$_\// }
+ $files->{$file} = -e $file;
+ warn __PACKAGE__ . qq(: Can't find file "$file": ignored.\n)
+ unless $files->{$file} || $file =~ /\(eval \d+\)/;
+ $files->{$file}
+}
+
+sub B::GV::find_cv
+{
+ return unless ${$_[0]->CV};
+
+ my $cv = $_[0]->CV;
+ push @Cvs, $cv;
+
+ if ($cv->PADLIST->can("ARRAY") &&
+ $cv->PADLIST->ARRAY &&
+ $cv->PADLIST->ARRAY->can("ARRAY"))
+ {
+ push @Cvs, grep class($_) eq "CV", $cv->PADLIST->ARRAY->ARRAY;
+ }
+};
+
+sub check_files
+{
+ # print "Checking files\n";
+
+ push @Cvs, grep class($_) eq "CV", B::main_cv->PADLIST->ARRAY->ARRAY;
+
+ walksymtable(\%main::, "find_cv", sub { 1 }, "");
+
+ for my $cv (@Cvs)
+ {
+ my $op = $cv->START;
+ # print "$op\n";
+ next unless $op->can("file") && class($op) ne "NULL" && is_state($op);
+
+ my $file = $op->file;
+ my $use = use_file($file);
+ # printf "%6s $file\n", $use ? "use" : "ignore";
+ }
+
+ # use Data::Dumper;
+ # print Dumper \%Devel::Cover::Files;
+}
+
+sub report
+{
+ my @collected = get_coverage();
+ return unless @collected;
+ set_coverage("none");
+
+ # print "Processing cover data\n@Inc\n";
+
+ $Coverage = coverage() || die "No coverage data available.\n";
+
+ # use Data::Dumper;
+ # print Dumper $Coverage;
+
+ get_cover(main_cv, main_root);
+ for my $cv (@Cvs)
+ {
+ my $start = $cv->START;
+ next unless $start->can("file") && use_file($start->file);
+ # print "File: ", $start->file, "\n";
+ get_cover($cv);
+ }
+
+ my $cover = Devel::Cover::DB->new
+ (
+ cover => $Cover,
+ collected => [ @collected ],
+ );
+ my $existing;
+ eval { $existing = Devel::Cover::DB->new(db => $DB) if $Merge };
+ $cover->merge($existing) if $existing;
+ $cover->indent($Indent);
+ $cover->write($DB);
+ $cover->print_summary if $Summary;
+}
+
+sub add_statement_cover
+{
+ my ($op) = @_;
+
+ get_location($op);
+ return unless $F;
+
+ return unless $Devel::Cover::collect;
+
+ # print "Statement: ", $op->name, "\n";
+
+ my $key = pack("I*", $$op) .