Permalink
Browse files

Handle || bless {}, "XXX" (reported by Marcel Grünauer).

 Add preliminary dor support.
 Add eval_sub test.
 Package buildperl script.
 Add -report option to cpancover.
 Update cpancover CSS.
 Partial solution for structure problems including debugging code.
 Add outputfile option to Html_basic.
  • Loading branch information...
1 parent f0c313c commit 84539e78aebb6af06c3326f5191eabf178875938 @pjcj committed Aug 18, 2005
Showing with 193 additions and 81 deletions.
  1. +1 −0 CHANGES
  2. +18 −7 Cover.xs
  3. +3 −0 MANIFEST
  4. +2 −0 MANIFEST.SKIP
  5. +1 −0 TODO
  6. +9 −2 cover
  7. +54 −30 cpancover
  8. +13 −9 lib/Devel/Cover.pm
  9. +32 −12 lib/Devel/Cover/DB.pm
  10. +38 −18 lib/Devel/Cover/DB/Structure.pm
  11. +14 −2 lib/Devel/Cover/Report/Html_basic.pm
  12. +7 −0 tests/cond_or
  13. +1 −1 tests/md5.t
View
@@ -5,6 +5,7 @@ Release 0.54 -
- Fix pod coverage percentages.
- Fix integer <-> pointer conversion warnings (Robin Barker).
- Add more tests for sort bug fixed in 0.53 (Rob Kinyon).
+ - Handle || bless {}, "XXX" (reported by Marcel Grünauer).
Release 0.53 - 17th April 2005
- Clean up database directories.
View
@@ -487,13 +487,20 @@ static void cover_logop(pTHX)
else
{
dSP;
- int left_val = SvTRUE(TOPs);
+ int left_val = SvTRUE(TOPs);
+#ifdef KEY_err
+ int left_val_def = SvOK(TOPs);
+#endif
NDEB(D(L, "cover_logop [%s]\n", get_key(PL_op)));
- 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 ||
+ 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 ||
+#ifdef KEY_err
+ PL_op->op_type == OP_DOR && !left_val_def ||
+ PL_op->op_type == OP_DORASSIGN && !left_val_def ||
+#endif
PL_op->op_type == OP_XOR)
{
/* no short circuit */
@@ -747,7 +754,7 @@ static int runops_cover(pTHX)
}
sv_setpv(lastfile, file);
}
-#if (PERL_VERSION > 6)
+#if PERL_VERSION > 6
if (SvTRUE(MY_CXT.module))
{
STRLEN mlen,
@@ -834,9 +841,13 @@ static int runops_cover(pTHX)
}
case OP_AND:
- case OP_OR:
case OP_ANDASSIGN:
+ case OP_OR:
case OP_ORASSIGN:
+#ifdef KEY_err
+ case OP_DOR:
+ case OP_DORASSIGN:
+#endif
case OP_XOR:
{
cover_logop(aTHX);
View
@@ -1,5 +1,6 @@
all_versions
BUGS
+buildperl
CHANGES
cover
Cover.xs
@@ -137,6 +138,8 @@ tests/E3.pm
tests/E4.pm
tests/eval1
tests/eval2
+tests/eval3
+tests/eval_sub.t
tests/eval_use.t
tests/fork
tests/if
View
@@ -19,3 +19,5 @@ lib/Devel/Cover/Inc.pm$
^Devel-Cover-
.patch$
.rej$
+.debug$
+^tmp/
View
1 TODO
@@ -32,6 +32,7 @@
- Overhaul test system. Include patt?
- Tests for INIT and END blocks included in required files when the
files are used in some runs.
+ - Make sure dor is handled correctly and add more tests to cond_or.
- Build:
- meta.yaml file to control pause indexing.
- Fix up make text and friends for module_ignore.
View
11 cover
@@ -134,7 +134,7 @@ sub main
}
print "$0 version $VERSION\n" and exit 0 if $Options->{version};
- pod2usage(-exitval => 0, -verbose => 0) if $Options->{help};
+ pod2usage(-exitval => 0, -verbose => 1) if $Options->{help};
pod2usage(-exitval => 0, -verbose => 2) if $Options->{info};
my $dbname = Cwd::abs_path(@ARGV ? shift @ARGV : "cover_db");
@@ -156,7 +156,8 @@ sub main
{
delete_db($dbname, @ARGV);
local $ENV{ -d "t" ? "HARNESS_PERL_SWITCHES" : "PERL5OPT" } =
- "-Mblib=$Bin -MDevel::Cover";
+ # "-Mblib=$Bin -MDevel::Cover";
+ "-MDevel::Cover";
system "make test";
$Options->{report} ||= "html";
}
@@ -190,6 +191,12 @@ sub main
$d->Indent(1);
$d->Sortkeys(1) if $] >= 5.008;
print $d->Dump;
+ my $structure = Devel::Cover::DB::Structure->new(base => $dbname);
+ $structure->read_all;
+ my $s = Data::Dumper->new([$structure], ["structure"]);
+ $s->Indent(1);
+ $s->Sortkeys(1) if $] >= 5.008;
+ print $s->Dump;
exit 0
}
View
@@ -33,6 +33,7 @@ my $Options =
directory => Cwd::cwd(),
force => 0,
module => [],
+ report => "html_basic",
};
sub get_options
@@ -51,6 +52,7 @@ sub get_options
outputfile=s
redo_cpancover_html!
redo_html!
+ report=s
version|v!
));
@@ -125,7 +127,8 @@ sub get_cover
my $od = "$Options->{outputdir}/$module";
my $of = $Options->{outputfile};
- sys "$^X $inc $s/cover -report html -outputdir $od -outputfile $of"
+ sys "$^X $inc $s/cover -report $Options->{report} " .
+ "-outputdir $od -outputfile $of"
if !-e "$od/$of" || $Options->{redo_html};
my $results = read_results;
@@ -148,7 +151,7 @@ sub write_stylesheet
print CSS <<EOF;
/* Stylesheet for Devel::Cover cpancover reports */
-/* You may modify this file to alter the appearance of your cpancover
+/* You may modify this file to alter the appearance of your coverage
* reports. If you do, you should probably flag it read-only to prevent
* future runs from overwriting it.
*/
@@ -160,9 +163,11 @@ body {
}
h1 {
- background-color: #3399ff;
+ text-align : center;
+ background-color: #cc99ff;
border: solid 1px #999999;
padding: 0.2em;
+ -moz-border-radius: 10px;
}
a {
@@ -172,60 +177,78 @@ a:visited {
color: #333333;
}
-code {
- white-space: pre;
-}
-
table {
-/* border: solid 1px #000000;*/
-/* border-collapse: collapse;*/
+ border-spacing: 1px;
}
-td,th {
- border: solid 1px #cccccc;
+tr {
+ text-align : center;
+ vertical-align: top;
}
-
-/* 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 {
+th,.h,.hh {
background-color: #cccccc;
border: solid 1px #333333;
padding-left: 0.2em;
padding-right: 0.2em;
+ width: 2.5em;
+ -moz-border-radius: 4px;
+}
+.hh {
+ width: 25%;
+}
+td {
+ border: solid 1px #cccccc;
+ -moz-border-radius: 4px;
}
-.uncovered {
+.hblank {
+ height: 0.5em;
+}
+.dblank {
+ border: none;
+}
+
+/* source code */
+pre,.s {
+ text-align: left;
+ font-family: monospace;
+ white-space: pre;
+ padding: 0.2em 0.5em 0em 0.5em;
+}
+
+/* Classes for color-coding coverage information:
+ * c0 : path not covered or coverage < 75%
+ * c1 : coverage >= 75%
+ * c2 : coverage >= 90%
+ * c3 : path covered or coverage = 100%
+ */
+.c0 {
background-color: #ff9999;
border: solid 1px #cc0000;
}
-.covered75 {
+.c1 {
background-color: #ffcc99;
border: solid 1px #ff9933;
}
-.covered90 {
+.c2 {
background-color: #ffff99;
border: solid 1px #cccc66;
}
-.covered {
+.c3 {
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"
+ $pc < 75 ? "c0" :
+ $pc < 90 ? "c1" :
+ $pc < 100 ? "c2" :
+ "c3"
}
sub write_html
@@ -249,7 +272,8 @@ sub write_html
{
my $dbdir = "$Options->{directory}/$module/cover_db";
next unless -d $dbdir;
- print "Adding $module\n";
+ chdir "$Options->{directory}/$module";
+ print "Adding $module from $dbdir\n";
my $db = Devel::Cover::DB->new(db => $dbdir);
# next unless $db->is_valid;
View
@@ -592,7 +592,7 @@ sub report
$Structure = Devel::Cover::DB::Structure->new(base => $DB);
$Structure->read_all;
$Structure->add_criteria(@collected);
- # use Data::Dumper; print STDERR Dumper $Structure;
+ # use Data::Dumper; print STDERR "Start structure", Dumper $Structure;
# print STDERR "Processing cover data\n@Inc\n";
$Coverage = coverage(1) || die "No coverage data available.\n";
@@ -612,7 +612,7 @@ sub report
my %files;
$files{$_}++ for keys %{$Run{count}}, keys %{$Run{vec}};
- for my $file (keys %files)
+ for my $file (sort keys %files)
{
# print "looking at $file\n";
unless (use_file($file))
@@ -624,7 +624,7 @@ sub report
next;
}
- $Structure->add_digest($file, \%Run);
+ # $Structure->add_digest($file, \%Run);
for my $run (keys %{$Run{vec}{$file}})
{
@@ -634,6 +634,8 @@ sub report
$Structure->store_counts($file);
}
+ # use Data::Dumper; print STDERR "End structure", Dumper $Structure;
+
my $run = time . ".$$." . sprintf "%05d", rand 2 ** 16;
my $cover = Devel::Cover::DB->new
(
@@ -685,9 +687,9 @@ sub add_statement_cover
get_location($op);
return unless $File;
- # print STDERR "Stmt $File:$Line: <$deparse> $op $$op ", $op->name, "\n";
+ # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n";
- $Structure->set_file($File);
+ $Run{digests}{$File} ||= $Structure->set_file($File);
my $key = get_key($op);
my $val = $Coverage->{statement}{$key} || 0;
my ($n, $new) = $Structure->add_count("statement");
@@ -772,6 +774,7 @@ sub add_condition_cover
my $type = $op->name;
$type =~ s/assign$//;
+ $type = "or" if $type eq "dor";
my $c = $Coverage->{condition}{$key};
@@ -786,7 +789,7 @@ sub add_condition_cover
$name = $r->first->name if $name eq "sassign";
# TODO - exec? any others?
# print STDERR "Name [$name]\n";
- if ($name =~ /^const|s?refgen|gelem|die|undef$/)
+ if ($name =~ /^const|s?refgen|gelem|die|undef|bless$/)
{
$c = [ $c->[3], $c->[1] + $c->[2] ];
$count = 2;
@@ -1048,6 +1051,7 @@ sub get_cover
my $pkg = $stash->NAME;
my $file = $cv->FILE;
my %opts;
+ $Run{digests}{$File} ||= $Structure->set_file($File);
if (ref $Coverage_options{pod})
{
my $p;
@@ -1178,9 +1182,9 @@ now defunct. See L<http://lists.perl.org/showlist.cgi?name=perl-qa>.
Perl 5.7.0 is unsupported. Perl 5.8.2 or greater is recommended.
Whilst Perl 5.6 should mostly work you will probably miss out on
coverage information which would be available using a more modern
-version and will likely run into bugs in perl. Perl 5.8.0 and 5.8.1
-will give slightly different results to more recent versions due to
-changes in the op tree.
+version and will likely run into bugs in perl. Perl 5.8.0 will give
+slightly different results to more recent versions due to changes in the
+op tree.
=item * The ability to compile XS extensions.
Oops, something went wrong.

0 comments on commit 84539e7

Please sign in to comment.