Skip to content
This repository
Browse code

import Devel::Cover 0.04

  • Loading branch information...
commit a9f2eeecdaa62ce043eaeec33d88cc247d06b001 1 parent a72ad45
Paul Johnson authored
4 CHANGES
@@ -10,3 +10,7 @@ Release 0.02 - 10th April 2001
10 10 Release 0.03 - 10th April 2001
11 11 - Add detailed output.
12 12 - Add -d option to turn it on.
  13 +
  14 +Release 0.04 - 12th April 2001
  15 + - Include Devel::Cover::Op
  16 + - Add condition coverage (sort of).
81 Cover.pm
@@ -12,10 +12,10 @@ use warnings;
12 12
13 13 use DynaLoader ();
14 14
15   -use Devel::Cover::Process 0.03;
  15 +use Devel::Cover::Process 0.04;
16 16
17 17 our @ISA = qw( DynaLoader );
18   -our $VERSION = "0.03";
  18 +our $VERSION = "0.04";
19 19
20 20 use B qw( class main_root main_start main_cv svref_2object OPf_KIDS );
21 21 use Data::Dumper;
@@ -43,10 +43,11 @@ sub import
43 43 while (@_)
44 44 {
45 45 local $_ = shift;
46   - /^-i/ && do { $Indent = shift; next };
47   - /^-o/ && do { $Output = shift; next };
48   - /^-S/ && do { $Summary = 0; next };
49   - /^-d/ && do { $Details = 1; next };
  46 + /^-indent/ && do { $Indent = shift; next };
  47 + /^-output/ && do { $Output = shift; next };
  48 + /^-inc/ && do { push @Inc, shift; next };
  49 + /^-summary/ && do { $Summary = shift; next };
  50 + /^-details/ && do { $Details = shift; next };
50 51 warn __PACKAGE__ . ": Unknown option $_ ignored\n";
51 52 }
52 53 }
@@ -61,13 +62,13 @@ sub report
61 62 {
62 63 return unless $Covering > 0;
63 64 cover(-1);
64   - # print "Processing cover data\n";
  65 + # print "Processing cover data\n@Inc\n";
65 66 get_subs("main");
66 67 INC:
67 68 while (my ($name, $file) = each %INC)
68 69 {
69   - # print "$name => $file\n";
70 70 for (@Inc) { next INC if $file =~ /^\Q$_/ }
  71 + # print "$name => $file\n";
71 72 $name =~ s/\.pm$//;
72 73 $name =~ s/\//::/g;
73 74 get_subs($name);
@@ -102,22 +103,50 @@ sub report
102 103 $cover->print_details if $Details;
103 104 }
104 105
  106 +my ($F, $L);
  107 +
105 108 sub walk_topdown
106 109 {
107 110 my ($op) = @_;
108   - push @{$Cover{$op->file}{$op->line}}, coverage()->{pack "I*", $$op} || 0
109   - if class($op) eq "COP";
  111 + my $class = class($op);
  112 + my $coverage = coverage()->{pack "I*", $$op};
  113 +
  114 + push @{$Cover{$F = $op->file}{statement}{$L = $op->line}}, $coverage || 0
  115 + if $class eq "COP";
  116 +
110 117 if ($op->can("flags") && ($op->flags & OPf_KIDS))
111 118 {
  119 + my $c;
112 120 for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
113 121 {
114   - walk_topdown($kid);
  122 + my $cov = walk_topdown($kid);
  123 + push @$c, $cov || 0 if $class eq "LOGOP";
115 124 }
  125 + push @{$Cover{$F}{condition}{$L}}, $c if $c;
116 126 }
117   - if (class($op) eq "PMOP" && ${$op->pmreplroot})
  127 +
  128 + if ($class eq "PMOP" && ${$op->pmreplroot})
118 129 {
119 130 walk_topdown($op->pmreplroot);
120 131 }
  132 +
  133 + $class eq "LISTOP" ? undef : $coverage
  134 +}
  135 +
  136 +sub find_first
  137 +{
  138 + my ($op) = @_;
  139 + my $c = coverage()->{pack "I*", $$op};
  140 + return $c if defined $c;
  141 + for (my $kid = $op->first; $$kid; $kid = $kid->sibling)
  142 + {
  143 + if ($op->can("flags") && ($op->flags & OPf_KIDS))
  144 + {
  145 + my $c = find_first($kid);
  146 + return $c if defined $c;
  147 + }
  148 + }
  149 + undef
121 150 }
122 151
123 152 sub get_subs
@@ -205,12 +234,12 @@ __END__
205 234
206 235 Devel::Cover - a module to provide code coverage for Perl
207 236
208   -Version 0.03 - 10th May 2001
  237 +Version 0.04 - 12th May 2001
209 238
210 239 =head1 SYNOPSIS
211 240
212 241 perl -MDevel::Cover prog args
213   - perl -MDevel::Cover=-o,prog.cov,-i,1 prog args
  242 + perl -MDevel::Cover=-output,prog.cov,-indent,1,-details,1 prog args
214 243
215 244 =head1 DESCRIPTION
216 245
@@ -225,13 +254,16 @@ This module provides code coverage for Perl.
225 254
226 255 If you can't guess by the version number this is an alpha release.
227 256
228   -Code coverage data are collected using a plugable runops subroutine
229   -which counts how many times each op is executed. These data are then
230   -mapped back to reality using the B compiler modules.
  257 +Code coverage data are collected using a plugable runops function which
  258 +counts how many times each op is executed. These data are then mapped
  259 +back to reality using the B compiler modules.
  260 +
  261 +At the moment, only statement coverage and condition coverage
  262 +information is reported. Coverage data for other metrics are collected,
  263 +but not reported. Coverage data for some metrics are not yet collected.
231 264
232   -At the moment, only statement coverage information is reported.
233   -Coverage data for other metrics are collected, but not reported.
234   -Coverage data for some metrics are not yet collected.
  265 +You may find that the results don't match your expectations. I would
  266 +imagine that at least one of them is wrong.
235 267
236 268 Requirements:
237 269 Perl 5.6.1 or 5.7.1.
@@ -239,10 +271,11 @@ Requirements:
239 271
240 272 =head1 OPTIONS
241 273
242   - -o file - Send output to file (default default.cov).
243   - -i indent - Set indentation level to indent. See Data::Dumper for details.
244   - -S - Don't print summary information.
245   - -d - Print detailed information.
  274 + -indent indent - Set indentation level to indent. See Data::Dumper for details.
  275 + -output file - Send output to file (default default.cov).
  276 + -inc path - Prefix of files to ignore (default @INC).
  277 + -summary val - Print summary information iff val is true (default on).
  278 + -details val - Print detailed information iff val is true (default off).
246 279
247 280 =head1 TUTORIAL
248 281
68 Cover/Op.pm
... ... @@ -0,0 +1,68 @@
  1 +# Copyright 2001, Paul Johnson (pjcj@cpan.org)
  2 +
  3 +# This software is free. It is licensed under the same terms as Perl itself.
  4 +
  5 +# The latest version of this software should be available from my homepage:
  6 +# http://www.pjcj.net
  7 +
  8 +package Devel::Cover::Op;
  9 +
  10 +use strict;
  11 +use warnings;
  12 +
  13 +our $VERSION = "0.04";
  14 +
  15 +use Devel::Cover qw(-inc B -indent 1 -details 1);
  16 +
  17 +my @Options;
  18 +
  19 +my %style =
  20 + ("terse" =>
  21 + ["(?(#label =>\n)?)(*( )*)#class (#addr) #name <#cover> (?([#targ])?) "
  22 + . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
  23 + "(*( )*)goto #class (#addr)\n",
  24 + "#class pp_#name"],
  25 + "concise" =>
  26 + ["#hyphseq2 #cover6 (*( (x( ;)x))*)<#classsym> "
  27 + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n",
  28 + " (*( )*) goto #seq\n",
  29 + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
  30 + "debug" =>
  31 + ["#class (#addr)\n\tcover\t\t#cover\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
  32 + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t"
  33 + . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n"
  34 + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
  35 + . "(?(\top_sv\t\t#svaddr\n)?)",
  36 + " GOTO #addr\n",
  37 + "#addr"],
  38 + );
  39 +
  40 +sub set_style
  41 +{
  42 + my ($style) = @_;
  43 + @ENV{qw(B_CONCISE_FORMAT B_CONCISE_GOTO_FORMAT B_CONCISE_TREE_FORMAT)} =
  44 + @{$style{$style}};
  45 +}
  46 +
  47 +sub import
  48 +{
  49 + my $class = shift;
  50 + @Options = ("-env");
  51 + set_style("concise");
  52 + for (@_)
  53 + {
  54 + /-(.*)/ && exists $style{$1}
  55 + ? set_style($1)
  56 + : push @Options, $_;
  57 + }
  58 + $ENV{B_CONCISE_SUB} = "Devel::Cover::Op::concise_op";
  59 +}
  60 +
  61 +END { require B::Concise; B::Concise::compile(@Options)->() }
  62 +
  63 +sub concise_op
  64 +{
  65 + my ($h, $op, $level, $format) = @_;
  66 + $h->{cover} = Devel::Cover::coverage()->{pack "I*", $$op} ||
  67 + ($h->{seq} ? "-" : "");
  68 +}
64 Cover/Process.pm
@@ -12,7 +12,7 @@ use warnings;
12 12
13 13 use Carp;
14 14
15   -our $VERSION = "0.03";
  15 +our $VERSION = "0.04";
16 16
17 17 sub new
18 18 {
@@ -74,26 +74,45 @@ sub calculate_summary
74 74 my $self = shift;
75 75 my ($force) = @_;
76 76 return if defined $self->{summary} && !$force;
77   - $self->{summary} = {};
78   - my $statements = 0;
79   - my $statements_covered = 0;
80   - for my $file (sort keys %{$self->{cover}})
  77 + my $s = $self->{summary} = {};
  78 +
  79 + my $cover = $self->{cover};
  80 + my ($t, $c, $lines);
  81 + for my $file (sort keys %$cover)
81 82 {
82   - my $lines = $self->{cover}{$file};
  83 + $t = $c = 0;
  84 + $lines = $cover->{$file}{statement};
  85 + for my $line (sort { $a <=> $b } keys %$lines)
  86 + {
  87 + my $l = $lines->{$line};
  88 + $t += @$l;
  89 + $c += grep { $_ } @$l;
  90 + }
  91 + $s->{$file}{statement}{total} = $t;
  92 + $s->{$file}{statement}{covered} = $c;
  93 + $s->{$file}{total}{total} += $t;
  94 + $s->{$file}{total}{covered} += $c;
  95 + $s->{Total}{statement}{total} += $t;
  96 + $s->{Total}{statement}{covered} += $c;
  97 + $s->{Total}{total}{total} += $t;
  98 + $s->{Total}{total}{covered} += $c;
  99 +
  100 + $t = $c = 0;
  101 + $lines = $cover->{$file}{condition};
83 102 for my $line (sort { $a <=> $b } keys %$lines)
84 103 {
85 104 my $l = $lines->{$line};
86   - $statements += @$l;
87   - $statements_covered += map { $_ || () } @$l;
  105 + $t += @$l;
  106 + $c += grep { !grep { !$_ } @$_ } @$l;
88 107 }
89   - $self->{summary}{$file}{statement}{total} = $statements;
90   - $self->{summary}{$file}{statement}{covered} = $statements_covered;
91   - $self->{summary}{$file}{total}{total} += $statements;
92   - $self->{summary}{$file}{total}{covered} += $statements_covered;
93   - $self->{summary}{Total}{statement}{total} += $statements;
94   - $self->{summary}{Total}{statement}{covered} += $statements_covered;
95   - $self->{summary}{Total}{total}{total} += $statements;
96   - $self->{summary}{Total}{total}{covered} += $statements_covered;
  108 + $s->{$file}{condition}{total} = $t;
  109 + $s->{$file}{condition}{covered} = $c;
  110 + $s->{$file}{total}{total} += $t;
  111 + $s->{$file}{total}{covered} += $c;
  112 + $s->{Total}{condition}{total} += $t;
  113 + $s->{Total}{condition}{covered} += $c;
  114 + $s->{Total}{total}{total} += $t;
  115 + $s->{Total}{total}{covered} += $c;
97 116 }
98 117 }
99 118
@@ -106,12 +125,11 @@ sub print_summary
106 125 {
107 126 my ($part, $critrion) = @_;
108 127 exists $part->{$critrion}
109   - ? $part->{$critrion}{total}
110   - ? sprintf "%6.2f", $part->{$critrion}{covered} * 100 /
111   - $part->{$critrion}{total}
112   - : "-"
  128 + ? sprintf "%6.2f", $part->{$critrion}{total}
  129 + ? $part->{$critrion}{covered} * 100 /
  130 + $part->{$critrion}{total}
  131 + : 100
113 132 : "n/a"
114   -
115 133 };
116 134
117 135 my $fmt = "%-42s %6s %6s %6s %6s %6s\n";
@@ -140,7 +158,7 @@ sub print_details
140 158 for my $file (@files)
141 159 {
142 160 print "$file\n\n";
143   - my $lines = $self->{cover}{$file};
  161 + my $lines = $self->{cover}{$file}{statement};
144 162 my $fmt = "%-5d: %6s %s\n";
145 163
146 164 open F, $file or croak "Unable to open $file: $!";
@@ -151,7 +169,7 @@ sub print_details
151 169 {
152 170 my @c = @{$lines->{$.}};
153 171 printf "%5d: %6d %s", $., shift @c, $_;
154   - printf " : %6d\n", $., shift @c while @c;
  172 + printf " : %6d\n", shift @c while @c;
155 173 }
156 174 else
157 175 {
1  MANIFEST
@@ -7,5 +7,6 @@ Makefile.PL
7 7 Cover.pm
8 8 Cover.xs
9 9 Cover/Process.pm
  10 +Cover/Op.pm
10 11 t/t1.t
11 12 t/T1.pm
4 Makefile.PL
@@ -16,8 +16,8 @@ use ExtUtils::MakeMaker;
16 16
17 17 $| = 1;
18 18
19   -my $Version = "0.03";
20   -my $Date = "10th May 2001";
  19 +my $Version = "0.04";
  20 +my $Date = "12th May 2001";
21 21 my $Author = 'pjcj@cpan.org';
22 22
23 23 my @perlbug = ("perlbug", "-a", $Author,
17 README
... ... @@ -1,7 +1,7 @@
1 1 NAME
2 2 Devel::Cover - a module to provide code coverage for Perl
3 3
4   - Version 0.03 - 10th May 2001
  4 + Version 0.04 - 12th May 2001
5 5
6 6 DESCRIPTION
7 7 Copyright 2001, Paul Johnson (pjcj@cpan.org)
@@ -16,13 +16,16 @@ DESCRIPTION
16 16
17 17 If you can't guess by the version number this is an alpha release.
18 18
19   - Code coverage data are collected using a plugable runops subroutine
20   - which counts how many times each op is executed. These data are then
21   - mapped back to reality using the B compiler modules.
  19 + Code coverage data are collected using a plugable runops function which
  20 + counts how many times each op is executed. These data are then mapped
  21 + back to reality using the B compiler modules.
22 22
23   - At the moment, only statement coverage information is reported. Coverage
24   - data for other metrics are collected, but not reported. Coverage data
25   - for some metrics are not yet collected.
  23 + At the moment, only statement coverage and condition coverage
  24 + information is reported. Coverage data for other metrics are collected,
  25 + but not reported. Coverage data for some metrics are not yet collected.
  26 +
  27 + You may find that the results don't match your expectations. I would
  28 + imagine that at least one of them is wrong.
26 29
27 30 Requirements: Perl 5.6.1 or 5.7.1. The ability to compile XS extensions.
28 31
164 t/t1.t
@@ -7,8 +7,8 @@
7 7 # The latest version of this software should be available from my homepage:
8 8 # http://www.pjcj.net
9 9
10   -use Devel::Cover::Process 0.03 qw( cover_read );
11   -use Devel::Cover 0.03 qw( -i 1 -o t1.cov );
  10 +use Devel::Cover::Process 0.04 qw( cover_read );
  11 +use Devel::Cover 0.04 qw( -indent 1 -output t1.cov );
12 12
13 13 use strict;
14 14 use warnings;
@@ -58,79 +58,131 @@ END
58 58 {
59 59 my $t1 = Devel::Cover::Process->new(file => "t1.cov" )->cover;
60 60 my $t2 = Devel::Cover::Process->new(filehandle => *DATA{IO})->cover;
61   - my $error = "keys";
  61 + my $error = "files";
62 62 my $ok = keys %$t1 == keys %$t2;
63 63 FILE:
64 64 for my $file (sort keys %$t1)
65 65 {
66   - $error = "file $file";
  66 + $error = "$file";
67 67 my $f1 = $t1->{$file};
68 68 my $f2 = delete $t2->{$file};
69 69 last FILE unless $ok &&= $f2;
70 70 $ok &&= keys %$f1 == keys %$f2;
71   - for my $line (sort keys %$f1)
  71 + for my $criterion (sort keys %$f1)
72 72 {
73   - $error = "file $file line $line";
74   - my $l1 = $f1->{$line};
75   - my $l2 = delete $f2->{$line};
76   - last FILE unless $ok &&= $l2;
77   - $ok &&= @$l1 == @$l2;
78   - for my $c1 (@$l1)
  73 + $error = "$file $criterion";
  74 + my $c1 = $f1->{$criterion};
  75 + my $c2 = delete $f2->{$criterion};
  76 + last FILE unless $ok &&= $c2;
  77 + for my $line (sort keys %$c1)
79 78 {
80   - my $c2 = shift @$l2;
81   - $error = "file $file line $line $c1 != $c2";
82   - last FILE unless $ok &&= !($c1 xor $c2);
  79 + $error = "$file $criterion $line";
  80 + my $l1 = $c1->{$line};
  81 + my $l2 = delete $c2->{$line};
  82 + last FILE unless $ok &&= $l2;
  83 + $ok &&= @$l1 == @$l2;
  84 + for my $v1 (@$l1)
  85 + {
  86 + my $v2 = shift @$l2;
  87 + $error = "$file $criterion $line $v1 != $v2";
  88 + last FILE unless $ok &&= !($v1 xor $v2);
  89 + }
  90 + $error = "$file $criterion $line extra";
  91 + last FILE unless $ok &&= !@$l2;
83 92 }
  93 + $error = "$file $criterion extra";
  94 + last FILE unless $ok &&= !keys %$c2;
84 95 }
  96 + $error = "$file extra";
  97 + last FILE unless $ok &&= !keys %$f2;
85 98 }
86   - ok $ok ? "done" : "mismatch at $error", "done";
  99 + $error = "extra" unless $ok &&= !keys %$t2;
  100 + ok $ok ? "done" : "mismatch: $error", "done";
87 101 }
88 102
89 103 __DATA__
  104 +
90 105 $cover = {
91 106 't/t1.t' => {
92   - '29' => [
93   - 1001
94   - ],
95   - '45' => [
96   - 1001
97   - ],
98   - '37' => [
99   - 1001
100   - ],
101   - '55' => [
102   - 1
103   - ],
104   - '24' => [
105   - 2
106   - ],
107   - '32' => [
108   - 1,
109   - 1001
110   - ],
111   - '40' => [
112   - 1001,
113   - 3003
114   - ],
115   - '42' => [
116   - 3003
117   - ],
118   - '35' => [
119   - 1002
120   - ],
121   - '51' => [
122   - 0
123   - ],
124   - '28' => [
125   - 1006
126   - ]
  107 + 'statement' => {
  108 + '29' => [
  109 + 1001
  110 + ],
  111 + '45' => [
  112 + 1001
  113 + ],
  114 + '37' => [
  115 + 1001
  116 + ],
  117 + '55' => [
  118 + 1
  119 + ],
  120 + '24' => [
  121 + 1
  122 + ],
  123 + '32' => [
  124 + 1,
  125 + 1001
  126 + ],
  127 + '40' => [
  128 + 1001,
  129 + 3003
  130 + ],
  131 + '42' => [
  132 + 3003
  133 + ],
  134 + '35' => [
  135 + 1002
  136 + ],
  137 + '51' => [
  138 + 0
  139 + ],
  140 + '28' => [
  141 + 1004
  142 + ]
  143 + },
  144 + 'condition' => {
  145 + '37' => [
  146 + [
  147 + 1001,
  148 + 1001
  149 + ]
  150 + ],
  151 + '32' => [
  152 + [
  153 + 1002,
  154 + 0
  155 + ]
  156 + ],
  157 + '40' => [
  158 + [
  159 + 4004,
  160 + 0
  161 + ]
  162 + ],
  163 + '51' => [
  164 + [
  165 + 1001,
  166 + 0,
  167 + 0
  168 + ]
  169 + ],
  170 + '35' => [
  171 + [
  172 + 1001,
  173 + 1001
  174 + ]
  175 + ]
  176 + }
127 177 },
128 178 't/T1.pm' => {
129   - '13' => [
130   - 1001
131   - ],
132   - '12' => [
133   - 1001
134   - ]
  179 + 'statement' => {
  180 + '13' => [
  181 + 1001
  182 + ],
  183 + '12' => [
  184 + 1001
  185 + ]
  186 + }
135 187 }
136 188 };

0 comments on commit a9f2eee

Please sign in to comment.
Something went wrong with that request. Please try again.