Skip to content
Browse files

import Devel::Cover 0.21

  • Loading branch information...
1 parent f9ee5ec commit 7a8002635c1231ae4e3097e0d0c296591469a864 @pjcj committed Nov 3, 2004
Showing with 6,260 additions and 1,032 deletions.
  1. +1 −1 BUGS
  2. +15 −0 CHANGES
  3. +260 −149 Cover.xs
  4. +51 −10 MANIFEST
  5. +10 −0 META.yml
  6. +29 −18 Makefile.PL
  7. +1 −1 README
  8. +5 −1 TODO
  9. +33 −30 cover
  10. +271 −45 cpancover
  11. +3 −3 create_gold
  12. +5 −5 gcov2perl
  13. +88 −23 lib/Devel/Cover.pm
  14. +4 −4 lib/Devel/Cover/Branch.pm
  15. +4 −4 lib/Devel/Cover/Condition.pm
  16. +4 −4 lib/Devel/Cover/Condition_and_3.pm
  17. +4 −4 lib/Devel/Cover/Condition_or_2.pm
  18. +4 −4 lib/Devel/Cover/Condition_or_3.pm
  19. +4 −4 lib/Devel/Cover/Condition_xor_4.pm
  20. +13 −13 lib/Devel/Cover/Criterion.pm
  21. +23 −6 lib/Devel/Cover/DB.pm
  22. +5 −5 lib/Devel/Cover/DB/File.pm
  23. +2 −2 lib/Devel/Cover/Op.pm
  24. +8 −8 lib/Devel/Cover/Pod.pm
  25. +8 −491 lib/Devel/Cover/Report/Html.pm
  26. +549 −0 lib/Devel/Cover/Report/Html_basic.pm
  27. +717 −0 lib/Devel/Cover/Report/Html_subtle.pm
  28. +5 −5 lib/Devel/Cover/Report/Text.pm
  29. +206 −0 lib/Devel/Cover/Report/Text2.pm
  30. +4 −4 lib/Devel/Cover/Statement.pm
  31. +58 −20 lib/Devel/Cover/Test.pm
  32. +5 −5 lib/Devel/Cover/Time.pm
  33. +567 −0 lib/Devel/Cover/Truth_Table.pm
  34. +2 −2 lib/Devel/Cover/Tutorial.pod
  35. +1 −0 session.vim
  36. +1 −1 test_output/cover/{cond_and → cond_and.5.006001}
  37. +103 −0 test_output/cover/cond_and.5.008
  38. +101 −0 test_output/cover/cond_and.5.008001
  39. +0 −137 test_output/cover/cond_branch
  40. +374 −0 test_output/cover/cond_branch.5.006001
  41. +374 −0 test_output/cover/cond_branch.5.008
  42. +348 −0 test_output/cover/cond_branch.5.008001
  43. +1 −1 test_output/cover/{cond_or → cond_or.5.006001}
  44. +106 −0 test_output/cover/cond_or.5.008
  45. +104 −0 test_output/cover/cond_or.5.008001
  46. +1 −1 test_output/cover/{cond_xor → cond_xor.5.006001}
  47. +57 −0 test_output/cover/cond_xor.5.008
  48. +55 −0 test_output/cover/cond_xor.5.008001
  49. +1 −1 test_output/cover/{eval1 → eval1.5.006001}
  50. +43 −0 test_output/cover/eval1.5.008
  51. +43 −0 test_output/cover/eval1.5.008001
  52. +2 −2 test_output/cover/{module1 → module1.5.006001}
  53. +105 −0 test_output/cover/module1.5.008
  54. +104 −0 test_output/cover/module1.5.008001
  55. +2 −2 test_output/cover/{module2 → module2.5.006001}
  56. +105 −0 test_output/cover/module2.5.008
  57. +104 −0 test_output/cover/module2.5.008001
  58. +31 −0 test_output/cover/module_import.5.006001
  59. +49 −0 test_output/cover/module_import.5.008
  60. +31 −0 test_output/cover/module_import.5.008001
  61. +55 −0 test_output/cover/pod.5.006001
  62. +55 −0 test_output/cover/pod.5.008
  63. +55 −0 test_output/cover/pod.5.008001
  64. +51 −0 test_output/cover/special_blocks.5.006001
  65. +51 −0 test_output/cover/special_blocks.5.008
  66. +51 −0 test_output/cover/special_blocks.5.008001
  67. +29 −0 test_output/cover/statement.5.006001
  68. +29 −0 test_output/cover/statement.5.008
  69. +29 −0 test_output/cover/statement.5.008001
  70. +1 −1 test_output/cover/{t0 → t0.5.006001}
  71. +83 −0 test_output/cover/t0.5.008
  72. +81 −0 test_output/cover/t0.5.008001
  73. +1 −1 test_output/cover/{t1 → t1.5.006001}
  74. +36 −0 test_output/cover/t1.5.008
  75. +36 −0 test_output/cover/t1.5.008001
  76. +1 −1 test_output/cover/{t2 → t2.5.006001}
  77. +69 −0 test_output/cover/t2.5.008
  78. +67 −0 test_output/cover/t2.5.008001
  79. +1 −1 tests/Module1.pm
  80. +1 −1 tests/Module2.pm
  81. +15 −0 tests/Module_import.pm
  82. +1 −1 tests/cond_and
  83. +180 −2 tests/cond_branch
  84. +1 −1 tests/cond_or
  85. +1 −1 tests/cond_xor
  86. +1 −1 tests/eval1
  87. +1 −1 tests/module1
  88. +1 −1 tests/module2
  89. +12 −0 tests/module_import
  90. +35 −0 tests/special_blocks
  91. +13 −0 tests/statement
  92. +1 −1 tests/t0
  93. +1 −1 tests/t1
  94. +1 −1 tests/t2
View
2 BUGS
@@ -1,2 +1,2 @@
- Code in BEGIN and END blocks is not reported.
-- Doesn't play nicely with Perl's testsuite.
+- Doesn't play nicely with all of Perl's testsuite.
View
15 CHANGES
@@ -114,3 +114,18 @@ Release 0.20 - 5th October 2002
- Add break after default to satisfy IBM's xlC compiler on AIX.
- Get things working with threads again.
- make realclean is.
+
+Release 0.21 - 1st September 2003
+ - Add cpancover.
+ - Handle $x || next and friends.
+ - Add html_subtle and text2 backends (Michael Carman).
+ - Rename html backend to html_basic.
+ - Make html backend a wrapper around preferred style, currently
+ html_subtle.
+ - Make time coverage a little more accurate. OK, a lot more accurate,
+ it's at least on the right line now, but I still wouldn't really
+ trust it.
+ - Fix pod coverage which has been broken for a while.
+ - Don't collect branch coverage when not asked for.
+ - Provide golden results for different Perl versions.
+ - Change some B::Deparse logic to mirror changes in 5.8.1/5.10.
View
409 Cover.xs
@@ -1,5 +1,5 @@
/*
- * Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+ * Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
*
* This software is free. It is licensed under the same terms as Perl itself.
*
@@ -41,7 +41,7 @@ extern "C" {
#define Time 0x00000020
#define All 0xffffffff
-static unsigned Covering = None;
+static unsigned Covering = All; /* Until we find out what we really want */
#define collecting(criteria) (Covering & (criteria))
@@ -53,6 +53,7 @@ static HV *Cover_hv,
*Pending_conditionals;
static int Got_condition = 0;
+static OP *Profiling_op = 0;
typedef int seq_t;
#define ch_sz (sizeof(void *) + sizeof(seq_t))
@@ -191,7 +192,7 @@ static void set_conditional(OP *op, int cond, int value)
count = av_fetch(conds, cond, 1);
sv_setiv(*count, value);
- NDEB(D(L, "Setitng %d conditional to %d at %p\n", cond, value, op));
+ NDEB(D(L, "Setting %d conditional to %d at %p\n", cond, value, op));
}
static void add_conditional(OP *op, int cond)
@@ -271,19 +272,188 @@ static OP *get_condition(pTHX)
return PL_op;
}
-static int runops_cover(pTHX)
+static void cover_cond()
{
- SV **count;
- IV c;
- HV *Files;
- int collecting_here = 1;
- char *lastfile = 0;
+ if (collecting(Branch))
+ {
+ dSP;
+ int val = SvTRUE(TOPs);
+ add_branch(PL_op, !val);
+ }
+}
+
+static void cover_logop()
+{
+ /*
+ * 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.
+ *
+ * This scheme also works for OP_XOR with a small modification
+ * because it doesn't short circuit. See the comment below.
+ *
+ * To find out when we get to the next op we change the op_ppaddr to
+ * point to get_condition(), which will do the necessary work and
+ * then reset and run the original op_ppaddr. We also store
+ * information in the Pending_conditionals hash. This is keyed on
+ * the op and the value is an array, the first element of which is
+ * the op_ppaddr we overwrote, and the subsequent elements are the
+ * ops about which we are collecting the condition coverage
+ * information. Note that an op may be collecting condition
+ * coverage information about a number of conditions.
+ */
+
+ if (!collecting(Condition))
+ return;
+
+ if (cLOGOP->op_first->op_type == OP_ITER)
+ {
+ /* loop - ignore it for now*/
+ }
+ else
+ {
+ dSP;
+ int left_val = SvTRUE(TOPs);
+ if (PL_op->op_type == OP_AND && left_val ||
+ PL_op->op_type == OP_ANDASSIGN && left_val ||
+ PL_op->op_type == OP_OR && !left_val ||
+ PL_op->op_type == OP_ORASSIGN && !left_val ||
+ PL_op->op_type == OP_XOR)
+ {
+ char *ch;
+ AV *conds;
+ SV **tmp,
+ *cond,
+ *ppaddr;
+ OP *next,
+ *right;
+
+ right = cLOGOP->op_first->op_sibling;
+ NDEB(op_dump(right));
+
+ if (right->op_type == OP_NEXT ||
+ right->op_type == OP_LAST ||
+ right->op_type == OP_REDO ||
+ right->op_type == OP_GOTO)
+ {
+ /*
+ * If the right side of the op is a branch, we don't
+ * care what its value is - it won't be returning one.
+ * We're just glad to be here, so we chalk up success.
+ */
+
+ add_conditional(PL_op, 2);
+ }
+ else
+ {
+ if (PL_op->op_type == OP_XOR && left_val)
+ {
+ /*
+ * This is an xor. It does not short circuit. We
+ * have just executed the right op, rather than the
+ * left op as with and and or. When we get to next
+ * we will have already done the xor, so we can work
+ * out what the value of the left op was.
+ *
+ * We set a flag in the first element of the array
+ * to say that we had a true value from the right
+ * op.
+ */
+
+ set_conditional(PL_op, 0, 1);
+ }
+
+ NDEB(op_dump(PL_op));
+
+ next = PL_op->op_next;
+ ch = get_key(next);
+ tmp = hv_fetch(Pending_conditionals, ch, ch_sz, 1);
+
+ if (SvROK(*tmp))
+ conds = (AV *)SvRV(*tmp);
+ else
+ *tmp = newRV_inc((SV*) (conds = newAV()));
+
+ if (av_len(conds) < 0)
+ {
+ NDEB(D(L, "setting f to %p\n", next->op_ppaddr));
+ ppaddr = newSViv((IV) next->op_ppaddr);
+ av_push(conds, ppaddr);
+ }
+
+ cond = newSViv((IV) PL_op);
+ av_push(conds, cond);
+
+ NDEB(D(L, "Adding conditional %p to %d, making %d\n",
+ next, next->op_seq, av_len(conds)));
+ NDEB(svdump(Pending_conditionals));
+ NDEB(op_dump(PL_op));
+ NDEB(op_dump(next));
+
+ next->op_ppaddr = get_condition;
+ }
+ }
+ else
+ {
+ add_conditional(PL_op, 3);
+ }
+ }
+}
#if CAN_PROFILE
- static COP *cop = 0;
- int lapsed;
- elapsed();
+
+static void cover_time()
+{
+ SV **count;
+ IV c;
+ char *ch;
+
+ if (collecting(Time))
+ {
+ /*
+ * Profiling information is stored against Profiling_op, the one
+ * we have just run.
+ */
+
+ NDEB(D(L, "Cop at %p, op at %p, timing %p\n", PL_curcop, PL_op, Profiling_op));
+
+ if (Profiling_op)
+ {
+ ch = get_key(Profiling_op);
+ count = hv_fetch(Times, ch, ch_sz, 1);
+ c = (SvTRUE(*count) ? SvIV(*count) : 0) +
+#if 0
+ Profiling == 1 ? cpu() : elapsed();
+#else
+ elapsed();
#endif
+ sv_setiv(*count, c);
+ NDEB(D(L, "Adding time: sum %d at %p\n", c, Profiling_op));
+ }
+ Profiling_op = PL_op;
+ }
+}
+
+#endif
+
+static int runops_cover(pTHX)
+{
+ SV **count;
+ IV c;
+ char *ch;
+ HV *Files;
+ int collecting_here = 1;
+ char *lastfile = 0;
NDEB(D(L, "runops_cover\n"));
@@ -316,12 +486,34 @@ static int runops_cover(pTHX)
Pending_conditionals = newHV();
}
+#if CAN_PROFILE
+ elapsed();
+#endif
+
for (;;)
{
NDEB(D(L, "running func %p\n", PL_op->op_ppaddr));
+#if CAN_PROFILE
+ /* Profile the first op */
+
+ if (!Profiling_op)
+ switch (PL_op->op_type)
+ {
+ case OP_SETSTATE:
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ Profiling_op = PL_op;
+ }
+#endif
+
if (!(PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)))
+ {
+#if CAN_PROFILE
+ cover_time();
+#endif
break;
+ }
if (Got_condition)
{
@@ -353,7 +545,18 @@ static int runops_cover(pTHX)
}
if (!collecting_here)
+ {
+#if CAN_PROFILE
+ cover_time();
+ Profiling_op = 0;
+#endif
continue;
+ }
+
+ /*
+ * We are about the run the op PL_op, so we'll collect
+ * information for it now.
+ */
switch (PL_op->op_type)
{
@@ -362,50 +565,24 @@ static int runops_cover(pTHX)
case OP_DBSTATE:
{
#if CAN_PROFILE
- /* lapsed = Profiling && PL_curcop != cop ? elapsed() : -1; */
- lapsed = collecting(Time) ? elapsed() : -1;
+ cover_time();
#endif
if (collecting(Statement))
{
- char *ch = get_key(PL_op);
+ 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);
- }
+ cover_cond();
break;
}
@@ -415,113 +592,7 @@ static int runops_cover(pTHX)
case OP_ORASSIGN:
case OP_XOR:
{
- /*
- * 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.
- *
- * This scheme also works for OP_XOR with a small
- * modification because it doesn't short circuit. See
- * the comment below.
- *
- * To find out when we get to the next op we change the
- * op_ppaddr to point to get_condition(), which will do
- * the necessary work and then reset and run the
- * original op_ppaddr. We also store information in the
- * Pending_conditionals hash. This is keyed on the op
- * and the value is an array, the first element of which
- * is the op_ppaddr we overwrote, and the subsequent
- * elements are the ops about which we are collecting
- * the condition coverage information. Note that an op
- * may be collecting condition coverage information
- * about a number of conditions.
- */
-
- if (!collecting(Condition))
- break;
-
- if (cLOGOP->op_first->op_type == OP_ITER)
- {
- /* loop - ignore it for now*/
- }
- else
- {
- dSP;
- int left_val = SvTRUE(TOPs);
- if (PL_op->op_type == OP_AND && left_val ||
- PL_op->op_type == OP_ANDASSIGN && left_val ||
- PL_op->op_type == OP_OR && !left_val ||
- PL_op->op_type == OP_ORASSIGN && !left_val ||
- PL_op->op_type == OP_XOR)
- {
- char *ch;
- AV *conds;
- SV **tmp,
- *cond,
- *ppaddr;
- OP *next;
-
- if (PL_op->op_type == OP_XOR && left_val)
- {
- /*
- * This is an xor. It does not short
- * circuit. We have just executed the right
- * op, rather than the left op as with and
- * and or. When we get to next we will have
- * already done the xor, so we can work out
- * what the value of the laft op was.
- *
- * We set a flag in the first element of the
- * array to say that we had a true value
- * from the right op.
- */
-
- set_conditional(PL_op, 0, 1);
- }
-
- next = PL_op->op_next;
- ch = get_key(next);
- tmp = hv_fetch(Pending_conditionals, ch, ch_sz, 1);
-
- if (SvROK(*tmp))
- conds = (AV *)SvRV(*tmp);
- else
- *tmp = newRV_inc((SV*) (conds = newAV()));
-
- if (av_len(conds) < 0)
- {
- NDEB(D(L, "setting f to %p\n", next->op_ppaddr));
- ppaddr = newSViv((IV) next->op_ppaddr);
- av_push(conds, ppaddr);
- }
-
- cond = newSViv((IV) PL_op);
- av_push(conds, cond);
-
- NDEB(D(L, "Adding conditional %p to %d, making %d\n",
- next, next->op_seq, av_len(conds)));
- NDEB(svdump(Pending_conditionals));
- NDEB(op_dump(PL_op));
- NDEB(op_dump(next));
-
- next->op_ppaddr = get_condition;
- }
- else
- {
- add_conditional(PL_op, 3);
- }
- }
+ cover_logop();
break;
}
@@ -547,6 +618,41 @@ static int runops_orig(pTHX)
return 0;
}
+#if 0
+static void cv_destroy_cb(pTHX_ CV *cv)
+{
+ SV *sv;
+ IV iv;
+ dSP;
+
+ PDEB(D(L, "cv_destroy_cb %p - %p\n", cv, Covering));
+
+ if (!Covering)
+ return;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+
+ sv = sv_newmortal();
+ iv = PTR2IV(cv);
+ sv_setiv(newSVrv(sv, "B::CV"), iv);
+
+ XPUSHs(sv);
+ /* XPUSHs(sv_2mortal(newSViv(cv))); */
+
+ PUTBACK;
+
+ call_pv("Devel::Cover::get_cover_x", G_DISCARD);
+
+ FREETMPS;
+ LEAVE;
+
+ NDEB(svdump(cv));
+}
+#endif
+
MODULE = Devel::Cover PACKAGE = Devel::Cover
PROTOTYPES: ENABLE
@@ -643,4 +749,9 @@ coverage()
ST(0) = &PL_sv_undef;
BOOT:
- PL_runops = runops_orig;
+ PL_runops = runops_orig;
+ /* PL_savebegin = TRUE; */
+ /* PL_savecheck = TRUE; */
+ /* PL_saveinit = TRUE; */
+ /* PL_saveend = TRUE; */
+ /* PL_cv_destroy_cb = cv_destroy_cb; */
View
61 MANIFEST
@@ -22,6 +22,10 @@ lib/Devel/Cover/DB/File.pm
lib/Devel/Cover/Test.pm
lib/Devel/Cover/Report/Text.pm
lib/Devel/Cover/Report/Html.pm
+lib/Devel/Cover/Report/Html_basic.pm
+lib/Devel/Cover/Report/Text2.pm
+lib/Devel/Cover/Report/Html_subtle.pm
+lib/Devel/Cover/Truth_Table.pm
cover
gcov2perl
create_gold
@@ -32,21 +36,58 @@ tests/t2
tests/eval1
tests/module1
tests/module2
+tests/module_import
tests/cond_and
tests/cond_or
tests/cond_xor
tests/cond_branch
+tests/special_blocks
+tests/statement
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
-test_output/cover/cond_xor
-test_output/cover/cond_branch
+tests/Module_import.pm
+test_output/cover/t0.5.006001
+test_output/cover/t1.5.006001
+test_output/cover/t2.5.006001
+test_output/cover/eval1.5.006001
+test_output/cover/module1.5.006001
+test_output/cover/module2.5.006001
+test_output/cover/module_import.5.006001
+test_output/cover/cond_and.5.006001
+test_output/cover/cond_or.5.006001
+test_output/cover/cond_xor.5.006001
+test_output/cover/cond_branch.5.006001
+test_output/cover/special_blocks.5.006001
+test_output/cover/statement.5.006001
+test_output/cover/pod.5.006001
+test_output/cover/t0.5.008
+test_output/cover/t1.5.008
+test_output/cover/t2.5.008
+test_output/cover/eval1.5.008
+test_output/cover/module1.5.008
+test_output/cover/module2.5.008
+test_output/cover/module_import.5.008
+test_output/cover/cond_and.5.008
+test_output/cover/cond_or.5.008
+test_output/cover/cond_xor.5.008
+test_output/cover/cond_branch.5.008
+test_output/cover/special_blocks.5.008
+test_output/cover/statement.5.008
+test_output/cover/pod.5.008
+test_output/cover/t0.5.008001
+test_output/cover/t1.5.008001
+test_output/cover/t2.5.008001
+test_output/cover/eval1.5.008001
+test_output/cover/module1.5.008001
+test_output/cover/module2.5.008001
+test_output/cover/module_import.5.008001
+test_output/cover/cond_and.5.008001
+test_output/cover/cond_or.5.008001
+test_output/cover/cond_xor.5.008001
+test_output/cover/cond_branch.5.008001
+test_output/cover/special_blocks.5.008001
+test_output/cover/statement.5.008001
+test_output/cover/pod.5.008001
lib/Devel/Cover/Tutorial.pod
session.vim
+META.yml Module meta-data (added by MakeMaker)
View
10 META.yml
@@ -0,0 +1,10 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Devel-Cover
+version: 0.21
+version_from:
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.16
View
47 Makefile.PL
@@ -1,6 +1,6 @@
#!/usr/local/bin/perl
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -15,11 +15,12 @@ use warnings;
use Cwd;
use ExtUtils::MakeMaker;
+use ExtUtils::Manifest "maniread";
$| = 1;
-my $Version = "0.20";
-my $Date = "5th October 2002";
+my $Version = "0.21";
+my $Date = "1st September 2003";
my $Author = 'pjcj@cpan.org';
my @perlbug = ("perlbug", "-a", $Author,
@@ -28,10 +29,10 @@ my @perlbug = ("perlbug", "-a", $Author,
my $Perlbug = join " ", map { / / ? "'$_'" : $_ } @perlbug;
-open M, "MANIFEST" or die "Cannot open MANIFEST: $!";
-my @files = map { split } <M>, "lib/Devel/Cover/Inc.pm";
+my @files = sort keys %{maniread()}, "lib/Devel/Cover/Inc.pm";
my @versions = grep { $_ ne "README" && $_ ne "Makefile.PL" } @files;
-close M or die "Cannot close MANIFEST: $!";
+
+my $test_version = $ENV{__COVER_GOLDEN_VERSION} || $];
my $base = getcwd;
@@ -41,7 +42,7 @@ 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)
+# Copyright 2001-2003, Paul Johnson (pjcj\@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -56,9 +57,9 @@ use strict;
use warnings;
our \$VERSION = "$Version";
-our \$Perl = "$^X";
-our \$Base = "$base";
-our \@Inc = qw( @inc );
+our \$Perl = "$^X";
+our \$Base = "$base";
+our \@Inc = qw( @inc );
1
EOI
@@ -81,7 +82,7 @@ for my $t (readdir D)
print T <<EOT;
#!$^X
-# Copyright 2002, Paul Johnson (pjcj\@cpan.org)
+# Copyright 2002-2003, Paul Johnson (pjcj\@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -113,10 +114,10 @@ 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.
+Template.pm 2.00 is required to run the HTML backend to cover and for
+cpancover. 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
@@ -152,6 +153,15 @@ else
print "not found\n\n$e\n";
}
+my $latest_tested = 5.008001;
+print <<EOM if $] > $latest_tested;
+
+Devel::Cover $Version has not been tested with perl $].
+Testing will take place against expected output from perl $latest_tested.
+You may well find failing tests.
+
+EOM
+
$ExtUtils::MakeMaker::Verbose = 0;
WriteMakefile
@@ -191,10 +201,10 @@ sub MY::libscan
my ($self, $path) = @_;
(my $p = $path) =~ s/^\$\(INST_LIB\)/lib/; # 5.6.1
# print "$path $p\n";
- my $wanted;
+ my $wanted = -d $p; # 5.9.0
for my $f (@files)
{
- last if $wanted = $p =~ /$f$/;
+ last if $wanted ||= $p =~ /$f$/;
}
$wanted && $path;
}
@@ -241,7 +251,8 @@ diff : pure_all
\$(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
+ gvim -d -geom 185x83+0+0 -font 8x13 \\
+ test_output/cover/\$(TEST).$test_version \$(TEST).out
gold : pure_all
\t \$(PERL) create_gold \$(TEST)
View
2 README
@@ -33,7 +33,7 @@ DESCRIPTION
Requirements:
- Perl 5.6.1 or 5.7.1.
+ Perl 5.6.1 or greater. (Perl 5.7.0 is also unsupported.)
The ability to compile XS extensions.
Pod::Coverage if you want pod coverage.
Template Toolkit 2 if you want HTML output.
View
6 TODO
@@ -1,5 +1,5 @@
- Indicate how to increase coverage?
-- Make the HTML output nicer.
+- Make the cpancover HTML output nicer.
- Collect data for path coverage.
- Tests.
- Documentation.
@@ -10,3 +10,7 @@
- Work with memoize.
- Fix up Devel::Cover::Op
- See if the XS code leaks, and fix it if it does.
+- Specify where html output goes.
+- Different criteria for different runs.
+- Subroutine coverage
+- Improve textual output
View
63 cover
@@ -1,6 +1,6 @@
#!/usr/local/bin/perl
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -12,43 +12,43 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Devel::Cover::DB 0.20;
+use Devel::Cover::DB 0.21;
use Getopt::Long;
use Pod::Usage;
my $Options =
{
- coverage => [],
- delete => 0,
- file => [],
- option => [],
- report => "",
- summary => 1,
+ coverage => [],
+ delete => 0,
+ file => [],
+ option => [],
+ report => "",
+ summary => 1,
};
sub get_options
{
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
- delete!
- help|h!
- file=s
- info|i!
- option=s
- report=s
- summary!
- version|v!
- ));
+ GetOptions($Options, # Store the options in the Options hash.
+ "write:s" => sub
+ {
+ @$Options{qw(write summary)} = ($_[1], 0)
+ },
+ qw(
+ coverage=s
+ delete!
+ help|h!
+ file=s
+ info|i!
+ option=s
+ report=s
+ summary!
+ version|v!
+ ));
}
sub main
@@ -77,8 +77,8 @@ sub main
{
for my $del ($dbname, @ARGV)
{
- print "Deleting database $dbname\n";
- my $db = Devel::Cover::DB->new(db => $dbname);
+ print "Deleting database $del\n";
+ my $db = Devel::Cover::DB->new(db => $del);
$db->delete;
}
exit 0;
@@ -157,6 +157,7 @@ The following command line options are supported:
-file filename - only report on the file (default all)
-write [db] - write the merged database (default off)
+ -delete - drop database(s) (default off)
-coverage criterion - report on criterion (default all available)
@@ -194,15 +195,17 @@ The following exit values are returned:
=head1 BUGS
-Huh?
+Did I mention that this is alpha code?
+
+See the BUGS file.
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
316 cpancover
@@ -1,6 +1,6 @@
#!/usr/local/bin/perl
-# Copyright 2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2002-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -12,19 +12,24 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Cwd;
+use Devel::Cover::DB 0.21;
+
+use Cwd ();
use File::Find ();
use Getopt::Long;
use Pod::Usage;
+use Template 2.00;
+
+my $Template;
my $Options =
{
cover_source => "/home/pjcj/g/perl/dev/Devel/Cover",
- directory => getcwd,
+ directory => Cwd::cwd(),
+ force => 0,
module => [],
- outputdir => getcwd,
};
sub get_options
@@ -34,19 +39,23 @@ sub get_options
qw(
cover_source=s
directory=s
+ force!
help|h!
info|i!
module=s
outputdir=s
+ redo_cpancover_html!
+ redo_html!
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};
+ $Options->{outputdir} ||= $Options->{directory};
push @{$Options->{module}}, @ARGV;
- unless (@{$Options->{module}})
+ if (!$Options->{redo_cpancover_html} && !@{$Options->{module}})
{
my $d = $Options->{directory};
opendir D, $d or die "Can't opendir $d: $!\n";
@@ -91,17 +100,31 @@ sub get_cover
my $d = "$Options->{directory}/$module";
chdir $d or die "Can't chdir $d: $!\n";
+ my $db = "$d/cover_db";
+
+ if (-d $db)
+ {
+ print "Already analysed\n";
+ # return;
+ }
+
my $s = $Options->{cover_source};
my $inc = "-I$s/blib/lib -I$s/blib/arch";
$ENV{HARNESS_PERL_SWITCHES} =
- "$inc -MDevel::Cover=+inc,$s,-ignore,\\\\bt/,-silent,1";
+ "$inc -MDevel::Cover=-db,$db,+inc,$s,-ignore,\\\\bt/,-silent,1";
- # sys "$^X $inc $s/cover -delete";
- # sys "make test";
+ if (! -d $db || $Options->{force})
+ {
+ print "Testing $module\n";
+ sys "$^X $inc $s/cover -delete $db";
+ sys "make test";
+ }
my $func = sub
{
- sys "$^X $inc $s/cover -report html" if -d && /^cover_db\z/s;
+ sys "$^X $inc $s/cover -report html"
+ if -d && /^cover_db\z/ &&
+ (!-e "$_/cover_db.html" || $Options->{redo_html});
};
File::Find::find($func, $d);
@@ -119,71 +142,274 @@ sub get_cover
close S or die "Can't close $f: $!\n";
}
-sub write_html
+sub write_stylesheet
{
- my $results = read_results;
- my $f = "$Options->{outputdir}/cpancover.html";
- print "Writing results to $f\n";
+ my $css = "$Options->{outputdir}/cpancover.css";
+ open CSS, ">", $css or return;
+ print CSS <<EOF;
+/* Stylesheet for Devel::Cover cpancover reports */
- open S, ">", $f or die "Can't open $f: $!\n";
- print S <<'EOH';
-<!--
+/* You may modify this file to alter the appearance of your cpancover
+ * reports. If you do, you should probably flag it read-only to prevent
+ * future runs from overwriting it.
+ */
-This file was generated by Devel::Cover Version 0.20
+/* Note: default values use the color-safe web palette. */
-Devel::Cover is copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+body {
+ font-family: sans-serif;
+}
-Devel::Cover is free. It is licensed under the same terms as Perl itself.
+h1 {
+ background-color: #3399ff;
+ border: solid 1px #999999;
+ padding: 0.2em;
+}
-The latest version of Devel::Cover should be available from my homepage:
-http://www.pjcj.net
+a {
+ color: #000000;
+}
+a:visited {
+ color: #333333;
+}
--->
+code {
+ white-space: pre;
+}
-<?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">
-<head>
- <title> Coverage Report </title>
-</head>
-<body>
-EOH
+table {
+/* border: solid 1px #000000;*/
+}
+td,th {
+ border: solid 1px #cccccc;
+}
+
+/* Classes for color-coding coverage information:
+ * header : column/row header
+ * uncovered : path not covered or coverage < 75%
+ * covered75 : coverage >= 75%
+ * covered90 : coverage >= 90%
+ * covered : path covered or coverage = 100%
+ */
+.header {
+ background-color: #cccccc;
+ border: solid 1px #333333;
+ padding-left: 0.2em;
+ padding-right: 0.2em;
+}
+.uncovered {
+ background-color: #ff9999;
+ border: solid 1px #cc0000;
+}
+.covered75 {
+ background-color: #ffcc99;
+ border: solid 1px #ff9933;
+}
+.covered90 {
+ background-color: #ffff99;
+ border: solid 1px #cccc66;
+}
+.covered {
+ background-color: #99ff99;
+ border: solid 1px #009900;
+}
+
+EOF
+ close CSS or die "Can't close $css: $!\n";
+}
+
+sub class
+{
+ my ($pc) = @_;
+ $pc eq "n/a" ? "na" :
+ $pc < 75 ? "uncovered" :
+ $pc < 90 ? "covered75" :
+ $pc < 100 ? "covered90" :
+ "covered"
+}
+
+sub write_html
+{
+ my $d = $Options->{directory};
+ chdir $d or die "Can't chdir $d: $!\n";
+
+ my $results = read_results;
+ my $f = "$Options->{outputdir}/cpancover.html";
+ print "\n\nWriting results to $f\n";
+
+ my $vars =
+ {
+ title => "CPAN Coverage report",
+ modules => [],
+ };
+
+ my %vals;
my $func = sub
{
if (/^cover_db\.html\z/s)
{
- my $d = $File::Find::dir;
- $d =~ s|/cover_db$||;
- print S "<a href=$File::Find::name>$d</a><p>\n"
+ my $base = $Options->{directory};
+ my $db = Devel::Cover::DB->new(db => "$base/$File::Find::dir");
+
+ my $criteria = $vars->{headers} ||=
+ [ grep(!/path|pod|time/, $db->all_criteria) ];
+
+ my %options = map { $_ => 1 } @$criteria;
+ $db->calculate_summary(%options);
+
+ my $module = $File::Find::dir;
+ $module =~ s|/cover_db$||;
+ push @{$vars->{modules}}, $module;
+ $vals{$module}{link} = $File::Find::name;
+
+ for my $criterion (@$criteria)
+ {
+ my $pc = $db->summary("Total", $criterion, "percentage");
+ $pc = defined $pc ? sprintf "%6.2f", $pc : "n/a";
+ $vals{$module}{$criterion}{pc} = $pc;
+ $vals{$module}{$criterion}{class} = class($pc);
+ }
}
};
+ $vars->{vals} = \%vals;
+
for my $mod (sort keys %$results)
{
File::Find::find($func, $mod);
}
- print S <<EOH;
-</body>
-</html>
-EOH
+ # use Data::Dumper;
+ # print Dumper $vars;
+
+ write_stylesheet;
+ $Template->process("summary", $vars, $f) or die $Template->error();
- close S or die "Can't close $f: $!\n";
}
sub main
{
get_options;
- # get_cover($_) for @{$Options->{module}}
+ $Template = Template->new
+ ({
+ LOAD_TEMPLATES =>
+ [
+ Devel::Cover::Cpancover::Template::Provider->new({}),
+ ],
+ });
+
+ get_cover($_) for @{$Options->{module}};
write_html;
}
-main
+package Devel::Cover::Cpancover::Template::Provider;
+
+use strict;
+use warnings;
+
+our $VERSION = "0.21";
+
+use base "Template::Provider";
+
+my %Templates;
+
+sub fetch
+{
+ my $self = shift;
+ my ($name) = @_;
+ # print "Looking for <$name>\n";
+ $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name)
+}
+
+$Templates{colours} = <<'EOT';
+[%
+ colours =
+ {
+ default => "#ffffad",
+ text => "#000000",
+ number => "#ffffc0",
+ error => "#ff0000",
+ ok => "#00ff00",
+ }
+%]
+
+[% MACRO bg BLOCK -%]
+bgcolor="[% colours.$colour %]"
+[%- END %]
+EOT
+
+$Templates{html} = <<'EOT';
+[% PROCESS colours %]
+
+<!--
+
+This file was generated by Devel::Cover Version 0.21
+
+Devel::Cover is copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
+
+Devel::Cover is free. It is licensed under the same terms as Perl itself.
+
+The latest version of Devel::Cover should be available from my homepage:
+http://www.pjcj.net
+
+-->
+
+<?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">
+<head>
+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"></meta>
+ <meta http-equiv="Content-Language" content="en-us"></meta>
+ <link rel="stylesheet" type="text/css" href="cpancover.css"></link>
+ <title> [% title %] </title>
+</head>
+<body>
+ [% content %]
+</body>
+</html>
+EOT
+
+$Templates{summary} = <<'EOT';
+[% WRAPPER html %]
+
+<h1> [% title %] </h1>
+
+<table border="2">
+
+ [% IF modules %]
+ <tr align="RIGHT" valign="CENTER">
+ <th class="header" align="LEFT"> File </th>
+ [% FOREACH header = headers %]
+ <th class="header"> [% header %] </th>
+ [% END %]
+ </tr>
+ [% END %]
+
+ [% FOREACH module = modules %]
+ <tr align="RIGHT" valign="CENTER">
+ <td align="LEFT">
+ <a href="[%- vals.$module.link -%]"> [% module %] </a>
+ </td>
+
+ [% FOREACH criterion = headers %]
+ <td class="[%- vals.$module.$criterion.class -%]">
+ [% vals.$module.$criterion.pc %]
+ </td>
+ [% END %]
+ </tr>
+ [% END %]
+
+</table>
+
+[% END %]
+EOT
+
+::main
__END__
@@ -228,11 +454,11 @@ The following exit values are returned:
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2002-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
6 create_gold
@@ -1,6 +1,6 @@
#!/usr/local/bin/perl
-# Copyright 2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2002-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -12,11 +12,11 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use blib;
-use Devel::Cover::Test 0.20;
+use Devel::Cover::Test 0.21;
my @tests = @ARGV;
View
10 gcov2perl
@@ -1,6 +1,6 @@
#!/usr/local/bin/perl
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -12,9 +12,9 @@ require 5.6.1;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Devel::Cover::DB 0.20;
+use Devel::Cover::DB 0.21;
use Getopt::Long;
use Pod::Usage;
@@ -128,11 +128,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
111 lib/Devel/Cover.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -11,32 +11,35 @@ use strict;
use warnings;
our @ISA = qw( DynaLoader );
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use DynaLoader ();
-use Devel::Cover::DB 0.20;
-use Devel::Cover::Inc 0.20;
+use Devel::Cover::DB 0.21;
+use Devel::Cover::Inc 0.21;
use B qw( class ppname main_cv main_start main_root walksymtable OPf_KIDS );
use B::Debug;
use B::Deparse;
use Cwd ();
+use Data::Dumper;
+
BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available.
my $Silent = 0; # Output nothing.
my $DB = "cover_db"; # DB name.
-my $Indent = 0; # Data::Dumper indent.
+my $Indent = 1; # 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 %Pod; # Pod coverage data.
my $Summary = 1; # Output coverage summary.
@@ -51,7 +54,7 @@ my %Coverage; # Coverage criteria to collect.
my $Cwd = Cwd::cwd(); # Where we start from.
-use vars qw($File $Line $Collect);
+use vars qw($File $Line $Collect %Files);
($File, $Line, $Collect) = ("", 0, 1);
@@ -178,6 +181,8 @@ sub get_location
$File = $op->file;
$Line = $op->line;
+ # warn "$File::$Line\n";
+
# If there's an eval, get the real filename. Enabled from $^P & 0x100.
($File, $Line) = ($1, $2) if $File =~ /^\(eval \d+\)\[(.*):(\d+)\]/;
@@ -205,7 +210,9 @@ sub use_file
my ($file) = @_;
$file = $1 if $file =~ /^\(eval \d+\)\[(.*):\d+\]/;
$file =~ s/ \(autosplit into .*\)$//;
- my $files = \%Devel::Cover::Files;
+ $file =~ s|\.\./\.\./lib/POSIX.pm|$INC{"POSIX.pm"}|e;
+ # print "checking <$file>\n";
+ my $files = \%Files;
return $files->{$file} if exists $files->{$file};
for (@Select) { return $files->{$file} = 1 if $file =~ /$_/ }
for (@Ignore) { return $files->{$file} = 0 if $file =~ /$_/ }
@@ -254,27 +261,32 @@ sub check_files
walksymtable(\%main::, "find_cv", sub { !$seen_pkg{$_[0]}++ });
- # use Data::Dumper;
# print Dumper \%seen_pkg;
- # print Dumper \%Devel::Cover::Files;
+ # print Dumper \%Files;
}
sub report
{
my @collected = get_coverage();
+ # print "Collected @collected\n";
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;
check_files();
get_cover(main_cv, main_root);
+ # print "init, ", Dumper \B::begin_av;
+ # print "init array, ", Dumper B::begin_av->ARRAY;
+ get_cover($_) for B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+ get_cover($_) for B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
+ get_cover($_) for B::init_av ->isa("B::AV") ? B::init_av ->ARRAY : ();
+ get_cover($_) for B::end_av ->isa("B::AV") ? B::end_av ->ARRAY : ();
get_cover($_) for @Cvs;
for my $file (keys %$Cover)
@@ -290,7 +302,12 @@ sub report
collected => [ @collected ],
);
my $existing;
- eval { $existing = Devel::Cover::DB->new(db => $DB) if $Merge };
+ eval
+ {
+ $existing = Devel::Cover::DB->new(db => $DB,
+ collected => [ @collected ])
+ if $Merge
+ };
$cover->merge($existing) if $existing;
$cover->indent($Indent);
$cover->write($DB);
@@ -318,17 +335,18 @@ sub add_statement_cover
sub add_branch_cover
{
- return unless $Collect;
+ return unless $Collect && $Coverage{branch};
my ($op, $type, $text, $file, $line) = @_;
$text =~ s/^\s+//;
$text =~ s/\s+$//;
my $key = pack("I*", $$op) . pack("I*", $op->seq);
- # print STDERR "Branch cover from $file:$line\n";
+ # print STDERR "Branch cover from $file:$line $type:$text\n";
my $c = $Coverage->{condition}{$key};
+ # print STDERR Dumper $c;
if ($type eq "and")
{
shift @$c;
@@ -459,7 +477,7 @@ sub B::Deparse::deparse
my $cond = $op->first;
my $true = $cond->sibling;
my $false = $true->sibling;
- if (!($cx == 0 && (is_scope($true) && $true->name ne "null") &&
+ if (!($cx < 1 && (is_scope($true) && $true->name ne "null") &&
(is_scope($false) || is_ifelse_cont($false))
&& $self->{'expand'} < 7))
{
@@ -488,7 +506,8 @@ sub B::Deparse::deparse
}
}
- $original_deparse->($self, @_);
+ my $d = eval { $original_deparse->($self, @_) };
+ $@ ? "Deparse error: $@" : $d
}
sub B::Deparse::logop
@@ -498,15 +517,15 @@ sub B::Deparse::logop
my $left = $op->first;
my $right = $op->first->sibling;
my ($file, $line) = ($File, $Line);
- if ($cx == 0 && is_scope($right) && $blockname && $self->{expand} < 7)
+ if ($cx < 1 && is_scope($right) && $blockname && $self->{expand} < 7)
{
# if ($a) {$b}
$left = $self->deparse($left, 1);
$right = $self->deparse($right, 0);
add_branch_cover($op, $lowop, "$blockname ($left)", $file, $line);
return "$blockname ($left) {\n\t$right\n\b}\cK"
}
- elsif ($cx == 0 && $blockname && !$self->{parens} && $self->{expand} < 7)
+ elsif ($cx < 1 && $blockname && !$self->{parens} && $self->{expand} < 7)
{
# $b if $a
$right = $self->deparse($right, 1);
@@ -547,13 +566,52 @@ sub B::Deparse::logassignop {
sub get_cover
{
- my $deparse = B::Deparse->new;
+ my $deparse = B::Deparse->new("-l");
my $cv = $deparse->{curcv} = shift;
+ if ($Pod && $Coverage{pod})
+ {
+ my $gv = $cv->GV;
+ unless ($gv->isa("B::SPECIAL"))
+ {
+ my $stash = $gv->STASH;
+ my $pkg = $stash->NAME;
+ my $file = $cv->FILE;
+ if ($Pod{$file} ||= Pod::Coverage->new(package => $pkg))
+ {
+ my $sub_name = $cv->GV->SAFENAME;
+ get_location($cv->START);
+ my $covered;
+ for ($Pod{$file}->covered)
+ {
+ $covered = 1, last if $_ eq $sub_name;
+ }
+ unless ($covered)
+ {
+ for ($Pod{$file}->uncovered)
+ {
+ $covered = 0, last if $_ eq $sub_name;
+ }
+ }
+ push @{$Cover->{$File}{pod}{$Line}[0]}, $covered if defined $covered;
+ }
+ }
+ }
+
@_ ? $deparse->deparse(shift, 0) : $deparse->deparse_sub($cv, 0)
}
+sub get_cover_x
+{
+ my $cv = shift;
+ printf "get_cover_x %p\n", $cv;
+ print "cv - $cv - ", Dumper $cv;
+ print ">>>";
+ print get_cover($cv);
+ print "<<<\n";
+}
+
bootstrap Devel::Cover $VERSION;
1
@@ -571,6 +629,10 @@ Devel::Cover - Code coverage metrics for Perl
perl -MDevel::Cover=-db,cover_db,-coverage,statement,time yourprog args
+ To test an uninstalled module:
+
+
+
=head1 DESCRIPTION
This module provides code coverage metrics for Perl.
@@ -604,15 +666,16 @@ now defunct. http://lists.perl.org/showlist.cgi?name=perl-qa
Requirements:
- Perl 5.6.1 or 5.7.1.
+ Perl 5.6.1 or greater. (Perl 5.7.0 is also unsupported.)
The ability to compile XS extensions.
Pod::Coverage if you want pod coverage.
Template Toolkit 2 if you want HTML output.
=head1 OPTIONS
- -coverage criterion - Turn on coverage for the specified criterion.
- -db cover_db - Store results in coverage db (default cover_db).
+ -coverage criterion - Turn on coverage for the specified criterion. Criteria
+ include statement, branch, path, pod, time, all and none.
+ -db cover_db - Store results in coverage db (default ./cover_db).
-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.
@@ -641,13 +704,15 @@ Some code and ideas cribbed from:
Did I mention that this is alpha code?
+See the BUGS file.
+
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Branch.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Branch;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Criterion";
@@ -76,11 +76,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Condition.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Condition;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Criterion";
@@ -80,11 +80,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Condition_and_3.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Condition_and_3;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Condition";
@@ -46,11 +46,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Condition_or_2.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Condition_or_2;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Condition";
@@ -46,11 +46,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Condition_or_3.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Condition_or_3;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Condition";
@@ -46,11 +46,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
8 lib/Devel/Cover/Condition_xor_4.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,7 +10,7 @@ package Devel::Cover::Condition_xor_4;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
use base "Devel::Cover::Condition";
@@ -45,11 +45,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
26 lib/Devel/Cover/Criterion.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,17 +10,17 @@ package Devel::Cover::Criterion;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Devel::Cover::Statement 0.20;
-use Devel::Cover::Branch 0.20;
-use Devel::Cover::Condition 0.20;
-use Devel::Cover::Condition_or_2 0.20;
-use Devel::Cover::Condition_or_3 0.20;
-use Devel::Cover::Condition_and_3 0.20;
-use Devel::Cover::Condition_xor_4 0.20;
-use Devel::Cover::Time 0.20;
-use Devel::Cover::Pod 0.20;
+use Devel::Cover::Statement 0.21;
+use Devel::Cover::Branch 0.21;
+use Devel::Cover::Condition 0.21;
+use Devel::Cover::Condition_or_2 0.21;
+use Devel::Cover::Condition_or_3 0.21;
+use Devel::Cover::Condition_and_3 0.21;
+use Devel::Cover::Condition_xor_4 0.21;
+use Devel::Cover::Time 0.21;
+use Devel::Cover::Pod 0.21;
sub new
{
@@ -78,11 +78,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
29 lib/Devel/Cover/DB.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,10 +10,10 @@ package Devel::Cover::DB;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Devel::Cover::DB::File 0.20;
-use Devel::Cover::Criterion 0.20;
+use Devel::Cover::DB::File 0.21;
+use Devel::Cover::Criterion 0.21;
use Carp;
use Data::Dumper;
@@ -46,6 +46,7 @@ sub new
{
$self->validate_db;
$file = "$self->{db}/$DB";
+ return $self unless -e $file;
open F, "<$file" or croak "Unable to open $file: $!";
$self->{filehandle} = *F{IO};
}
@@ -223,6 +224,22 @@ sub _merge_array
push @$into, @$from;
}
+sub files
+{
+ my $self = shift;
+ (grep($_ ne "Total", sort @{$self->{summary}}), "Total")
+}
+
+sub summary
+{
+ my $self = shift;
+ my ($file, $criteriion, $part) = @_;
+ my $f = $self->{summary}{$file};
+ return $f unless $f && defined $criteriion;
+ my $c = $f->{$criteriion};
+ $c && defined $part ? $c->{$part} : $c
+}
+
sub calculate_summary
{
my $self = shift;
@@ -542,11 +559,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002
+Version 0.21 - 1st September 2003
=head1 LICENCE
-Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
This software is free. It is licensed under the same terms as Perl itself.
View
10 lib/Devel/Cover/DB/File.pm
@@ -1,4 +1,4 @@
-# Copyright 2001-2002, Paul Johnson (pjcj@cpan.org)
+# Copyright 2001-2003, Paul Johnson (pjcj@cpan.org)
# This software is free. It is licensed under the same terms as Perl itself.
@@ -10,9 +10,9 @@ package Devel::Cover::DB::File;
use strict;
use warnings;
-our $VERSION = "0.20";
+our $VERSION = "0.21";
-use Devel::Cover::Criterion 0.20;
+use Devel::Cover::Criterion 0.21;
sub calculate_summary
{
@@ -78,11 +78,11 @@ Huh?
=head1 VERSION
-Version 0.20 - 5th October 2002