├── tests ├── random │ └── dir │ │ └── file ├── COP.pm ├── IncSub.pm ├── Accessor_maker.pm ├── dist │ └── DC-Test-Dist │ │ ├── t │ │ └── t1.t │ │ ├── Makefile.PL │ │ └── lib │ │ └── DC │ │ └── Test │ │ ├── Dist │ │ └── M1.pm │ │ └── Dist.pm ├── trivial ├── redefine_sub ├── xor_constant_fold ├── padrange ├── v-58x ├── Taint.pm ├── E2.pm ├── E3.pm ├── E4.pm ├── exec ├── module_import ├── eval_merge_0 ├── eval_merge_1 ├── Module_import.pm ├── statement ├── taint ├── cond_chained ├── require ├── t1 ├── bigint ├── cop ├── alias1 ├── eval_nested ├── PodMod.pm ├── deparse ├── default_param ├── skip ├── destroy ├── accessor ├── overload_bool ├── module_relative ├── moose_basic ├── special_blocks ├── eval2 ├── overload_bool2 ├── eval_merge ├── branch_return_sub ├── module_ignore ├── subs_only ├── fork ├── Alias1.pm ├── eval3 ├── cond_xor ├── alias ├── exec_die ├── module1 ├── module2 ├── t2 ├── Module1.pm ├── if ├── Module2.pm ├── .uncoverable ├── t0 ├── moose_constraint ├── overloaded ├── bug_and ├── pod_nocp ├── pod ├── eval1 ├── moo_cond ├── cond_and ├── sort ├── inc_sub ├── moose_cond ├── uncoverable ├── cond_or.pl ├── readonly ├── dynamic_subs ├── dbm_cond ├── eval_use.t ├── eval_merge.t ├── eval_merge_sep.t ├── eval_sub.t ├── md5.t ├── change.t └── cond_or ├── t ├── internal │ ├── inc_filter │ │ ├── cwd │ │ │ └── lib │ │ │ │ └── .dummy │ │ └── cwd_lib │ │ │ └── .dummy │ ├── subprocess.t │ ├── launch.t │ ├── inc_filter.t │ └── criteria.t └── regexp │ └── regexp_eval.t ├── utils ├── build_cpancover_perl ├── install_dev_modules ├── setup ├── scanuncov ├── create_all_gold ├── typemap ├── run_cpancover ├── makeh ├── cpanmcover ├── create_gold ├── bisect.sh ├── Devel │ └── Cover │ │ └── BuildUtils.pm ├── install │ └── System.pm └── mail_contributors ├── .whitesource ├── .travis.yml ├── MANIFEST.SKIP ├── .gitignore ├── docs ├── BUGS ├── RELEASE └── cpancover ├── lib └── Devel │ └── Cover │ ├── Html_Common.pm │ ├── Condition_xor_4.pm │ ├── Condition_or_2.pm │ ├── Condition_and_2.pm │ ├── Condition_or_3.pm │ ├── Condition_and_3.pm │ ├── Report │ ├── Html.pm │ └── Json.pm │ ├── Subroutine.pm │ ├── Statement.pm │ ├── Condition.pm │ ├── Dumper.pm │ ├── Pod.pm │ ├── Time.pm │ ├── DB │ ├── File.pm │ ├── IO │ │ └── Storable.pm │ └── IO.pm │ ├── Util.pm │ ├── Branch.pm │ └── Annotation │ └── Random.pm └── test_output └── cover ├── trivial.5.006001 ├── xor_constant_fold.5.006001 ├── padrange.5.008001 ├── v-58x.5.006001 ├── padrange.5.006001 ├── padrange.5.008 ├── md5.5.006001 ├── pod.5.006001 ├── exec.5.006001 ├── pod_nocp.5.006001 ├── statement.5.006001 ├── taint.5.006001 ├── v-58x.5.008 ├── module_import.5.006001 ├── bigint.5.006001 ├── cop.5.006001 ├── change.5.006001 ├── t1.5.006001 ├── pod.5.008 ├── pod_nocp.5.008 ├── deparse.5.006001 ├── moose_basic.5.010000 ├── redefine_sub.5.006001 ├── t1.5.008 ├── eval_nested.5.006001 ├── destroy.5.006001 ├── skip.5.006001 ├── taint.5.008 ├── overload_bool2.5.006001 ├── bigint.5.008 ├── special_blocks.5.006001 ├── cop.5.008 ├── bigint.5.008001 ├── default_param.5.006001 ├── fork.5.006001 ├── eval_nested.5.008 ├── module_ignore.5.006001 ├── exec_die.5.006001 ├── overload_bool.5.006001 ├── subs_only.5.006001 ├── deparse.5.008 ├── alias.5.006001 ├── default_param.5.014000 ├── cond_xor.5.006001 └── default_param.5.008001 /tests/random/dir/file: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /t/internal/inc_filter/cwd/lib/.dummy: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /t/internal/inc_filter/cwd_lib/.dummy: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/COP.pm: -------------------------------------------------------------------------------- 1 | #line 64 "Parser.yp" 2 | 1; 3 | -------------------------------------------------------------------------------- /tests/IncSub.pm: -------------------------------------------------------------------------------- 1 | package IncSub; 2 | 3 | sub check { print "***********\n" } 4 | 5 | 1 6 | -------------------------------------------------------------------------------- /utils/build_cpancover_perl: -------------------------------------------------------------------------------- 1 | #!/bin/sh -x 2 | 3 | JOBS=16 4 | perlbrew uninstall cpancover 5 | perlbrew install perl-5.18.2 --as cpancover -j $JOBS -nf 6 | -------------------------------------------------------------------------------- /tests/Accessor_maker.pm: -------------------------------------------------------------------------------- 1 | package Accessor_maker; 2 | sub import { 3 | no strict 'refs'; 4 | *{ caller() . '::' . 'foo' } = sub { $_[0]->{ 'foo' } }; 5 | } 6 | 1; 7 | -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.8" 4 | - "5.10" 5 | - "5.12" 6 | - "5.14" 7 | - "5.16" 8 | - "5.18" 9 | notifications: 10 | email: 11 | on_success: always 12 | on_failure: always 13 | -------------------------------------------------------------------------------- /utils/install_dev_modules: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | cpan App:cpanminus < /dev/null 4 | cpanm Template Perl::Tidy Pod::Coverage Test::Differences Browser::Open \ 5 | Moose Moo DBM::Deep Readonly Dist::Zilla 6 | dzil authordeps | cpanm 7 | dzil listdeps | cpanm 8 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/t/t1.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use DC::Test::Dist; 7 | 8 | my $d = DC::Test::Dist->new; 9 | 10 | $d->d1("a"); 11 | is $d->d1, "a", "d1 correctly set and retrieved"; 12 | 13 | done_testing 14 | -------------------------------------------------------------------------------- /tests/trivial: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | my $x = 1; 11 | -------------------------------------------------------------------------------- /tests/redefine_sub: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | sub s1 { 4 | my $t = shift; 5 | if ($t > 5) { 6 | print 5; 7 | } else { 8 | print $t; 9 | } 10 | } 11 | 12 | my $c = *main::s1{CODE}; 13 | 14 | *main::s1 = sub { 15 | print "extra"; 16 | &$c(@_); 17 | }; 18 | 19 | s1(1); 20 | s1(7); 21 | -------------------------------------------------------------------------------- /tests/xor_constant_fold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | 1 xor 0; 11 | -------------------------------------------------------------------------------- /tests/padrange: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | my @s; 11 | for (@s) {} 12 | -------------------------------------------------------------------------------- /tests/v-58x: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use 5.006; 11 | 12 | my $x = 1; 13 | -------------------------------------------------------------------------------- /tests/Taint.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 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 Taint; 9 | 10 | eval 1 unless defined &X; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /tests/E2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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 E2; 9 | 10 | print "E2\n"; 11 | 12 | sub E2 { print "E2::E2\n" } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/E3.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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 E3; 9 | 10 | print "E3\n"; 11 | 12 | sub E3 { print "E3::E3\n" } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/E4.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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 E4; 9 | 10 | print "E4\n"; 11 | 12 | sub E4 { print "E4::E4\n" } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/exec: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2007-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | $x = 1; 11 | 12 | exec "echo foo"; 13 | 14 | die "Unreachable"; 15 | -------------------------------------------------------------------------------- /tests/module_import: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | BEGIN { push @INC, "tests" } 11 | 12 | use Module_import; 13 | -------------------------------------------------------------------------------- /tests/eval_merge_0: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | use E2; 13 | use E3; 14 | 15 | E2::E2; 16 | E3::E3; 17 | -------------------------------------------------------------------------------- /tests/eval_merge_1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | use E3; 13 | use E4; 14 | 15 | E3::E3; 16 | E4::E4; 17 | -------------------------------------------------------------------------------- /utils/setup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # . ./utils/setup 4 | 5 | tidy () { echo -n $1 | perl -naF: -e 'print join ":", grep !$s{$_}++ && -e, @F'; } 6 | dc_home=$PWD 7 | export PATH=$(tidy $dc_home/utils:$PATH) 8 | 9 | if [ ! -z $ZSH_VERSION ]; then 10 | _dc() { 11 | reply=(`utils/dc options`) 12 | } 13 | compctl -K _dc dc 14 | fi 15 | 16 | export CPANCOVER_LOCAL=1 17 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.org$ 2 | \.bak$ 3 | ~$ 4 | \.orig$ 5 | Makefile$ 6 | Makefile\.old$ 7 | blib/ 8 | pm_to_blib$ 9 | \.version$ 10 | ^t/e2e/ 11 | \.gz$ 12 | \.c$ 13 | \.o$ 14 | \.bs$ 15 | cover_db/ 16 | core$ 17 | \.out$ 18 | lib/Devel/Cover/Inc.pm$ 19 | ^Devel-Cover- 20 | \.patch$ 21 | \.rej$ 22 | \.debug$ 23 | ^tmp/ 24 | ^bugs/ 25 | \.git/ 26 | \.tar.bz2$ 27 | MYMETA\. 28 | tags 29 | -------------------------------------------------------------------------------- /tests/Module_import.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 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 Module_import; 9 | 10 | sub import { 11 | print "Module_import\n"; 12 | } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/statement: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | my $pi = 3.14159; my $r = 4; 11 | my $c = 2 * $pi * $r; 12 | my $a = $pi * $r * $r; 13 | -------------------------------------------------------------------------------- /tests/taint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | use lib "tests"; 13 | 14 | use Taint; 15 | 16 | print "taint\n"; 17 | -------------------------------------------------------------------------------- /tests/cond_chained: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | sub t1 { 4 | for my $x (0, 1, 2) { 5 | my $y = 3 if $x && $x == 2; 6 | } 7 | } 8 | 9 | sub t2 { 10 | for my $x (0, 1, 2) { 11 | return if $x && $x == 2; 12 | } 13 | } 14 | 15 | sub t3 { 16 | for my $x (0, 1, 2) { 17 | last if $x && $x == 2 && $x == 2 && $x == 2; 18 | } 19 | } 20 | 21 | t1; 22 | t2; 23 | t3; 24 | -------------------------------------------------------------------------------- /tests/require: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib -d "t" ? "." : ".."; 11 | use File::Spec; 12 | require File::Spec->catfile("tests", "E2.pm"); 13 | -------------------------------------------------------------------------------- /tests/t1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my @x; 14 | 15 | sub xx { 16 | $x[shift]++; 17 | } 18 | 19 | xx(4); 20 | -------------------------------------------------------------------------------- /tests/bigint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Math::BigInt ":constant"; 14 | 15 | my $x = 1; 16 | print $x if 1 >= $x; 17 | -------------------------------------------------------------------------------- /tests/cop: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use lib "tests"; 14 | 15 | $SIG{__WARN__} = sub { die @_ }; 16 | require COP; 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.org 2 | *.bak 3 | *~ 4 | Cover.bs 5 | Cover.c 6 | Cover.o 7 | Makefile 8 | Makefile.old 9 | blib/ 10 | cover_db*/ 11 | t/e2e/ 12 | lib/Devel/Cover/Inc.pm 13 | pm_to_blib 14 | *.out 15 | *.tar.bz2 16 | *.tar.gz 17 | *.patch 18 | *.orig 19 | *.rej 20 | tmp/ 21 | MYMETA.* 22 | Cover.def 23 | dll.base 24 | dll.exp 25 | Devel-Cover-* 26 | tags 27 | README 28 | .build/ 29 | callgrind.out.* 30 | staging/ 31 | *.sw? 32 | -------------------------------------------------------------------------------- /tests/alias1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | use lib "tests"; 13 | 14 | use Alias1; 15 | 16 | is_3digits(1234); 17 | is_3digits(123); 18 | 19 | exit; 20 | -------------------------------------------------------------------------------- /tests/eval_nested: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | eval "eval q[ sub config { {} } ]"; 14 | 15 | my $e1 = config() || {}; 16 | my $e2 = config()->{mail} || {}; 17 | -------------------------------------------------------------------------------- /tests/PodMod.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2005-2014, Paul Johnson (paul@pjcj.net) 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 PodMod; 9 | 10 | use base "Module1"; 11 | 12 | sub vv { die } 13 | sub ww { die } 14 | sub yy { die } 15 | 16 | 1 17 | 18 | __END__ 19 | 20 | =head2 vv 21 | 22 | vv 23 | 24 | =cut 25 | -------------------------------------------------------------------------------- /tests/deparse: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -l 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use B::Deparse; 14 | 15 | my $xx = sub { 16 | print "xx"; 17 | }; 18 | 19 | print B::Deparse->new->coderef2text($xx) 20 | -------------------------------------------------------------------------------- /tests/default_param: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | sub p { 14 | my $x = shift || 11; 15 | my $y = shift || []; 16 | my $z = shift || {}; 17 | } 18 | 19 | p $_, $_, $_ for 0, 1; 20 | -------------------------------------------------------------------------------- /tests/skip: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | sub main { 11 | my ($debug) = @_; 12 | print "main\n"; 13 | print "debug1\n" if $debug; 14 | if ($debug) { 15 | print "debug2\n"; 16 | } 17 | } 18 | 19 | main 0; 20 | -------------------------------------------------------------------------------- /tests/destroy: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | package Destroy; 11 | 12 | sub new { bless {}, shift } 13 | 14 | my $x; 15 | 16 | sub DESTROY { 17 | $x++; 18 | $x++; 19 | } 20 | 21 | package main; 22 | 23 | my $d = Destroy->new; 24 | -------------------------------------------------------------------------------- /tests/accessor: -------------------------------------------------------------------------------- 1 | package cm3; 2 | sub new { bless $_[1], $_[0] } 3 | 4 | use lib "tests"; 5 | 6 | # comment/uncomment one or the other: 7 | use Accessor_maker; 8 | # sub foo { $_[0]->{ 'foo' } } 9 | 10 | package main; 11 | 12 | sub test { 13 | my $self = shift; 14 | 15 | print 'un' unless defined $self->foo; 16 | print "defined\n"; 17 | 18 | my $foo = $self->foo; 19 | print 'un' unless defined $foo; 20 | print "defined\n"; 21 | } 22 | 23 | test( cm3->new({}) ); 24 | test( cm3->new({foo => 1}) ); 25 | -------------------------------------------------------------------------------- /tests/overload_bool: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | package Foo; 11 | use overload 12 | '""' => sub { shift->render}, 13 | bool => sub { die; 1 }; 14 | 15 | sub render { 16 | "foo"; 17 | } 18 | 19 | my $foo = 1; 20 | bless {}, 'Foo' if $foo; 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /tests/module_relative: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.008 || $^O eq "cygwin" 11 | # __COVER__ skip_reason Busted on 5.6 and cygwin 12 | 13 | BEGIN { chdir "tests/random/dir" } 14 | use lib "../.."; 15 | use strict; 16 | use Module_import; 17 | -------------------------------------------------------------------------------- /tests/moose_basic: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") 11 | # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover 12 | 13 | package Foo; 14 | use Moose; 15 | __PACKAGE__->meta->make_immutable; 16 | -------------------------------------------------------------------------------- /tests/special_blocks: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my $x; 14 | 15 | BEGIN { 16 | $x++ 17 | } 18 | 19 | CHECK { 20 | $x++ 21 | } 22 | 23 | INIT { 24 | $x++ 25 | } 26 | 27 | END { 28 | $x++ 29 | } 30 | 31 | $x++; 32 | -------------------------------------------------------------------------------- /tests/eval2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | $x = shift || 0; 13 | print "1 - $x\n"; 14 | if ($x) { eval 'use E2' } 15 | print "3 - $x\n"; 16 | if ($x < 4) { eval 'use E3' } 17 | print "4 - $x\n"; 18 | if ($x < 6) { eval 'use E4' } 19 | print "5 - $x\n"; 20 | -------------------------------------------------------------------------------- /tests/overload_bool2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | { 14 | package Cat; 15 | 16 | use overload (bool => "meh"); 17 | 18 | sub meh { 1 } 19 | } 20 | 21 | my $string = "hi"; 22 | my $x = bless \$string, "Cat"; 23 | 24 | my $fn = eval 'require $x'; 25 | -------------------------------------------------------------------------------- /utils/scanuncov: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | use strict; 3 | use Digest::MD5; 4 | 5 | process_file($_) for @ARGV; 6 | 7 | sub process_file { 8 | my $file = shift; 9 | open my $fh, $file or die $!; 10 | while (<$fh>) { 11 | my ($count, $crit, $reason) = m/# uncoverable:\s+(\d+)\s+(\w+)\s+(.*$)/ 12 | or next; 13 | my $md5 = Digest::MD5->new->add($_)->hexdigest; 14 | $crit =~ s/s$//; 15 | for (0..$count-1) { 16 | print "$file $crit $md5 $_ 0 $reason\n"; 17 | } 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tests/eval_merge: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | $x = shift || 0; 13 | print "1 - $x\n"; 14 | if (!$x) { 15 | eval "use E2"; eval "use E3"; 16 | E2::E2(); E3::E3(); 17 | } else { 18 | eval "use E3"; eval "use E4"; 19 | E3::E3(); E4::E4(); 20 | } 21 | print "2 - $x\n"; 22 | -------------------------------------------------------------------------------- /tests/branch_return_sub: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | sub my_sqrt { 14 | my $n = shift; 15 | 16 | if ( !defined($n) || ($n < 0) ) { 17 | return undef; 18 | } 19 | 20 | return sqrt($n); 21 | } 22 | 23 | my_sqrt(25); 24 | my_sqrt(-2); 25 | my_sqrt(undef); 26 | -------------------------------------------------------------------------------- /t/internal/subprocess.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | if ($] < 5.008000) 7 | { 8 | plan skip_all => "Test requires perl 5.8.0 or greater"; 9 | } 10 | else 11 | { 12 | plan tests => 2; 13 | } 14 | 15 | my $cmd = qq[$^X -e "print q(Hello, world.)"]; 16 | my $output = `$cmd 2>&1`; 17 | is($output, "Hello, world.", "simple test with perl -e"); 18 | 19 | $cmd = qq[$^X -Mblib -MDevel::Cover=-silent,1 -e "print q(Hello, world.)"]; 20 | $output = `$cmd 2>&1`; 21 | is($output, "Hello, world.", "test with perl -MDevel::Cover,-silent,1 -e"); 22 | -------------------------------------------------------------------------------- /tests/module_ignore: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ ignore Module1 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use lib "tests"; 16 | 17 | use Module1; 18 | 19 | my @x; 20 | 21 | for (0 .. 10) { 22 | if (Module1::zz($_)) { 23 | $x[0]++; 24 | } else { 25 | $x[1]++; 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /tests/subs_only: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ test_parameters -subs_only,1 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use lib "tests"; 16 | 17 | my @x; 18 | 19 | sub xx { 20 | $x[shift]++; 21 | } 22 | 23 | for (0 .. 10) { 24 | if (time) { 25 | xx(0); 26 | } else { 27 | $x[1]++; 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /tests/fork: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $^O eq "MSWin32" || $] == 5.008007 11 | # __COVER__ skip_reason Fork unreliable 12 | 13 | $x = 1; 14 | 15 | die unless defined ($pid = fork); 16 | 17 | if ($pid) { 18 | $x = 2; 19 | waitpid $pid, 0; 20 | } else { 21 | $x = 3; 22 | } 23 | 24 | print "$x: $$\n"; 25 | -------------------------------------------------------------------------------- /tests/Alias1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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 Alias1; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Exporter; 14 | 15 | our @ISA = qw(Exporter); 16 | our @EXPORT = qw(is_3digits); 17 | 18 | sub is_3digits { 19 | my $val = shift; 20 | my $retval = undef; 21 | $retval=1 if $val =~ /^\d{3}$/; 22 | return $retval; 23 | } 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /tests/eval3: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | $x = shift || 0; 13 | print "1 - $x\n"; 14 | if ($x) { eval 'sub s1 { print "s1\n" }'; s1() } 15 | print "3 - $x\n"; 16 | if ($x < 4) { eval 'sub s2 { print "s2\n" }'; s2() } 17 | print "4 - $x\n"; 18 | if ($x < 6) { eval 'sub s3 { print "s3\n" }'; s3() } 19 | print "5 - $x\n"; 20 | -------------------------------------------------------------------------------- /tests/cond_xor: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my $i = 1; 14 | my $j = 0; 15 | 16 | for my $y (0, 1, 1, 1) { 17 | for my $z (0, 0, 1) { 18 | my $x = $y ^ $z; 19 | $x = ($y xor $z); 20 | 21 | my $p = ($i xor $y); 22 | $p = ($j xor $y); 23 | $p ^= $y; 24 | } 25 | } 26 | -------------------------------------------------------------------------------- /tests/alias: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | package Foo; 11 | 12 | sub is_3digits { 13 | my $val = shift; 14 | my $retval = undef; 15 | $retval=1 if $val =~ /^\d{3}$/; 16 | return $retval; 17 | } 18 | 19 | package main; 20 | 21 | *main::is_3digits = *Foo::is_3digits; 22 | # delete $Foo::{is_3digits}; 23 | 24 | is_3digits(1234); 25 | is_3digits(123); 26 | -------------------------------------------------------------------------------- /tests/exec_die: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $^O eq "MSWin32" 11 | # __COVER__ skip_reason Fork uses threads on Windows 12 | 13 | die unless defined ($pid = fork); 14 | 15 | if ($pid) { 16 | wait; 17 | } else { 18 | local *Devel::Cover::_report = sub { die "Badness happened!" }; 19 | exec "echo We want to be able to see this."; 20 | } 21 | -------------------------------------------------------------------------------- /tests/module1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ changes s/56.3/56.2/ 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use lib "tests"; 16 | 17 | use Module1; 18 | 19 | my @x; 20 | 21 | sub xx { 22 | $x[shift]++; 23 | Module1::zz(0); 24 | } 25 | 26 | for (0 .. 10) { 27 | if (time) { 28 | xx(0); 29 | } else { 30 | $x[1]++; 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /tests/module2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ changes s/56.3/56.2/ 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use lib "tests"; 16 | 17 | use Module2; 18 | 19 | my @x; 20 | 21 | sub xx { 22 | $x[shift]++; 23 | NotModule2::zz(0); 24 | } 25 | 26 | for (0 .. 10) { 27 | if (time) { 28 | xx(0); 29 | } else { 30 | $x[1]++; 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /tests/t2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my @x; 14 | 15 | sub xx { 16 | $x[shift]++; 17 | } 18 | 19 | for (0 .. 10) { 20 | time && 21 | $x[1]++; 22 | 23 | $x[2]++ 24 | if time; 25 | 26 | for (0 .. 2) { 27 | $x[3]++; 28 | } 29 | 30 | if (time) { 31 | xx(4); 32 | } else { 33 | $x[5]++; 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /tests/Module1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 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 Module1; 9 | 10 | my $y = 7; 11 | $y++; 12 | 13 | sub _aa { 14 | $y++; 15 | die; 16 | die; 17 | } 18 | 19 | sub xx { 20 | $y++; 21 | die; 22 | } 23 | 24 | sub yy { 25 | $y++; 26 | } 27 | 28 | sub zz { 29 | my $x = shift; 30 | $x++; 31 | } 32 | 33 | 1 34 | 35 | __END__ 36 | 37 | =head2 yy 38 | 39 | yy 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /tests/if: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my ($x, $p, $q, $r, $s); 14 | 15 | $x = 0; 16 | 17 | if ($x) { 18 | $p++ 19 | } 20 | 21 | unless ($x) { 22 | $q++ 23 | } 24 | 25 | $x = 1; 26 | 27 | if ($x) { 28 | $r++ 29 | } 30 | 31 | if ($x) { 32 | $r++ 33 | } else { 34 | $s++ 35 | } 36 | 37 | unless ($x) { 38 | $s++ 39 | } 40 | -------------------------------------------------------------------------------- /utils/create_all_gold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | require 5.6.1; 11 | 12 | use strict; 13 | use warnings; 14 | 15 | # VERSION 16 | 17 | my @tests = @ARGV; 18 | die "Only one test allowed" if @tests > 1; 19 | my $fn = @tests ? $tests[0] : ""; 20 | unlink for ; 21 | # print "tests [@tests]\n"; 22 | exec $^X, "utils/all_versions", "make", "gold", "TEST=@tests" 23 | -------------------------------------------------------------------------------- /tests/Module2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 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 NotModule2; 9 | 10 | my $y = 7; 11 | $y++; 12 | 13 | sub _aa { 14 | $y++; 15 | die; 16 | die; 17 | } 18 | 19 | sub _xx { 20 | $y++; 21 | die; 22 | } 23 | 24 | sub yy { 25 | $y++; 26 | } 27 | 28 | sub zz { 29 | my $x = shift; 30 | $x++; 31 | } 32 | 33 | 1 34 | 35 | __END__ 36 | 37 | =head2 yy 38 | 39 | yy 40 | 41 | =cut 42 | -------------------------------------------------------------------------------- /tests/.uncoverable: -------------------------------------------------------------------------------- 1 | tests/uncoverable statement 20f752895295d69b6b73da4d9921a9ed 0 0 Can't get to this statement 2 | tests/uncoverable statement 89c43a57239a432b0517549f6b8f9feb 0 0 Can't get to this statement 3 | tests/uncoverable statement ba33ccd5188f01ebbd59be35038fe0cb 0 0 Can't get to this statement 4 | tests/uncoverable branch 9389290602dbf70585e0467e6cb28669 0 0 Branch can't be true 5 | tests/uncoverable condition 9389290602dbf70585e0467e6cb28669 0 0 $x can't be false 6 | tests/uncoverable condition 9389290602dbf70585e0467e6cb28669 0 2 $y can't be false 7 | tests/uncoverable subroutine ba33ccd5188f01ebbd59be35038fe0cb 0 0 Can't run this subroutine 8 | -------------------------------------------------------------------------------- /utils/typemap: -------------------------------------------------------------------------------- 1 | TYPEMAP 2 | 3 | B::OP T_OP_OBJ 4 | B::AV T_SV_OBJ 5 | 6 | INPUT 7 | T_OP_OBJ 8 | if (SvROK($arg)) { 9 | IV tmp = SvIV((SV*)SvRV($arg)); 10 | $var = INT2PTR($type,tmp); 11 | } 12 | else 13 | croak(\"$var is not a reference\") 14 | 15 | T_SV_OBJ 16 | if (SvROK($arg)) { 17 | IV tmp = SvIV((SV*)SvRV($arg)); 18 | $var = INT2PTR($type,tmp); 19 | } 20 | else 21 | croak(\"$var is not a reference\") 22 | 23 | 24 | OUTPUT 25 | T_OP_OBJ 26 | sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); 27 | 28 | T_SV_OBJ 29 | make_sv_object(aTHX_ ($arg), (SV*)($var)); 30 | -------------------------------------------------------------------------------- /tests/t0: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my @x; 14 | 15 | my $y = 1; 16 | 17 | for (0 .. 10) { 18 | $y && 19 | $x[1]++; 20 | 21 | $y && 22 | $x[0]++ && 23 | $x[1]++; 24 | 25 | $x[2]++ 26 | if $y; 27 | 28 | for (0 .. 2) { 29 | $x[3]++; 30 | } 31 | 32 | if ($y) { 33 | $x[4]++; 34 | } else { 35 | $x[5]++; 36 | } 37 | } 38 | 39 | # print join(", ", @x), "\n"; 40 | -------------------------------------------------------------------------------- /tests/moose_constraint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") 11 | # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover 12 | 13 | use 5.010; 14 | 15 | package Foo; 16 | 17 | use Moose; 18 | 19 | has bar => ( 20 | is => 'rw', 21 | isa => 'Maybe[Str]', 22 | ); 23 | 24 | package main; 25 | 26 | my $example = Foo->new(); 27 | $example->bar('whatever'); 28 | say $example->bar(); 29 | -------------------------------------------------------------------------------- /tests/overloaded: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2003-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # Example stolen from overload documentation 11 | 12 | package two_face; 13 | 14 | sub new { my $p = shift; bless [@_], $p } 15 | use overload '""' => \&str, '0+' => \&num, fallback => 1; 16 | sub num {shift->[1]} 17 | sub str {shift->[0]} 18 | 19 | package main; 20 | 21 | my $seven = new two_face ("vii", 7); 22 | printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; 23 | print "seven contains `i'\n" if $seven =~ /i/; 24 | -------------------------------------------------------------------------------- /tests/bug_and: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | my $x = 1; 11 | my $y = 1; 12 | 13 | if ($x && !$y) { 14 | die "Urgh"; 15 | } 16 | 17 | if ($x && $y) { 18 | } 19 | 20 | unless ($x && $y) { 21 | die "Urgh"; 22 | } 23 | 24 | if (!($x && $y)) { 25 | die "Urgh"; 26 | } 27 | 28 | # TODO - this does not get reported on correctly. It is reported identically 29 | # to the first case, but it should be the same as cases 2 - 4. 30 | if (!$x || !$y) { 31 | die "Urgh"; 32 | } 33 | -------------------------------------------------------------------------------- /tests/pod_nocp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ criteria pod-nocp-also_private-xx 11 | # __COVER__ skip_test eval "use Pod::Coverage"; $@ 12 | # __COVER__ skip_reason Pod::Coverage unavailable 13 | 14 | use strict; 15 | use warnings; 16 | 17 | use lib "tests"; 18 | 19 | use PodMod; 20 | 21 | my @x; 22 | 23 | sub xx 24 | { 25 | $x[shift]++; 26 | Module1::zz(0); 27 | } 28 | 29 | for (0 .. 10) 30 | { 31 | if (time) 32 | { 33 | xx(0); 34 | } 35 | else 36 | { 37 | $x[1]++; 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /tests/pod: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ criteria pod-also_private-xx 11 | # __COVER__ skip_test eval "use Pod::Coverage::CountParents"; $@ 12 | # __COVER__ skip_reason Pod::Coverage::CountParents unavailable 13 | 14 | use strict; 15 | use warnings; 16 | 17 | use lib "tests"; 18 | 19 | use PodMod; 20 | 21 | my @x; 22 | 23 | sub xx 24 | { 25 | $x[shift]++; 26 | Module1::zz(0); 27 | } 28 | 29 | for (0 .. 10) 30 | { 31 | if (time) 32 | { 33 | xx(0); 34 | } 35 | else 36 | { 37 | $x[1]++; 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /t/internal/launch.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | opendir my $d, 'lib/Devel/Cover/Report'; 7 | my @reporters = grep { s/\.pm$// } readdir($d); 8 | closedir $d; 9 | 10 | plan tests => scalar @reporters; 11 | 12 | my @reporters_with_launch = qw( 13 | Html Html_basic Html_minimal Html_subtle 14 | ); 15 | 16 | # Check that the expected reporters support the launch feature 17 | for my $reporter (@reporters) { 18 | my $class = 'Devel::Cover::Report::' . $reporter; 19 | eval "require $class"; 20 | 21 | if (grep { $_ eq $reporter } @reporters_with_launch) { 22 | ok($class->can('launch'), "$reporter supports launch"); 23 | } 24 | else { 25 | ok(! $class->can('launch'), "$reporter does not support launch"); 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /utils/run_cpancover: -------------------------------------------------------------------------------- 1 | #!/bin/sh -x 2 | 3 | JOBS=16 4 | export PATH=$PERLBREW_ROOT/perls/cpancover/bin:$PATH 5 | rm -rf ~/.cpanm 6 | rm -rf ~/cpancover 7 | cpan App::cpanminus 8 | cpanm -nf . 9 | cpanm -nf Capture::Tiny Parallel::Iterator Template Class::XSAccessor \ 10 | Moo namespace::clean 11 | cpanm -nf App::cpanoutdated 12 | cpan-outdated | cpanm -nf 13 | perl -Mblib bin/cpancover -force -verbose -results_dir ~/cpancover \ 14 | -workers $JOBS -module_file utils/cpancover_modules \ 15 | -noempty_cpanm_dir 16 | find ~/cpancover -type f -exec gzip -9 {} \; 17 | chmod -R o=g ~/cpancover 18 | www=/usr/share/nginx/www 19 | new=$www/`date +%F` 20 | sudo mv $new $new.$$ 21 | sudo cp -a ~/cpancover $new 22 | sudo rm $www/latest 23 | sudo ln -s $new $www/latest 24 | -------------------------------------------------------------------------------- /t/internal/inc_filter.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package test_inc_filter; 5 | 6 | use Test::More; 7 | use Cwd 'abs_path'; 8 | use File::Spec; 9 | use Devel::Cover::Util 'remove_contained_paths'; 10 | 11 | plan tests => 2; 12 | 13 | run(); 14 | 15 | sub run { 16 | my $cwd = abs_path "t/internal/inc_filter/cwd"; 17 | 18 | my @inc_tests = qw( cwd cwd/lib cwd_lib ); 19 | my @inc = map "t/internal/inc_filter/$_", @inc_tests; 20 | @inc = map { abs_path( $_ ), File::Spec->rel2abs( $_ ) } @inc; 21 | @inc = map { $_, lcfirst $_ } @inc; 22 | 23 | @inc = remove_contained_paths( $cwd, @inc ); 24 | 25 | is ~~ ( grep { /cwd_lib/ } @inc ), 4, 26 | "cwd_lib was left in the array four times"; 27 | is ~~ @inc, 4, "no other paths were left in the array"; 28 | 29 | return; 30 | } 31 | -------------------------------------------------------------------------------- /tests/eval1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] == 5.010 11 | # __COVER__ skip_reason One test fails only under make test on 5.10.0 unthreaded 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use lib -d "t" ? "t" : ".."; 17 | 18 | my $x; 19 | 20 | eval <<'EOS'; 21 | sub e { 22 | $x++; 23 | $x 24 | } 25 | EOS 26 | 27 | eval <<'EOS'; 28 | sub f { 29 | $x++; 30 | $x 31 | } 32 | 33 | sub g { 34 | $x++; 35 | } 36 | 37 | sub h { 38 | $x++; 39 | } 40 | EOS 41 | 42 | e(); 43 | e(); 44 | e(); 45 | f(); 46 | f(); 47 | h(); 48 | h(); 49 | h(); 50 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | require 5.006001; 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use ExtUtils::MakeMaker; 16 | 17 | # VERSION 18 | our $LVERSION = do { eval '$VERSION' || "0.001" }; # for development purposes 19 | 20 | $ExtUtils::MakeMaker::Verbose = 0; 21 | 22 | WriteMakefile( 23 | NAME => "DC::Test::Dist", 24 | VERSION => $LVERSION, 25 | AUTHOR => 'Paul Johnson ', 26 | ABSTRACT_FROM => "lib/DC/Test/Dist.pm", 27 | clean => { FILES => "cover_db" }, 28 | ); 29 | -------------------------------------------------------------------------------- /tests/moo_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.008002 || !(eval "use Moo 1.000003; 23") 11 | # __COVER__ skip_reason Moo not available 12 | 13 | use strict; 14 | use warnings; 15 | 16 | package Cover_branch_bug_Moo; 17 | 18 | use Moo; 19 | 20 | has config => ( is => 'lazy' ); 21 | has config2 => ( is => 'ro' ); 22 | 23 | __PACKAGE__->new( config => {}, config2 => {} )->trigger; 24 | __PACKAGE__->new( config => {debug => 1}, config2 => {debug => 1} )->trigger; 25 | 26 | sub trigger { 27 | 1 if $_[0]->config->{debug}; 28 | 1 if $_[0]->config2->{debug}; 29 | } 30 | -------------------------------------------------------------------------------- /tests/cond_and: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my @x; 14 | 15 | my $y = 1; 16 | my $z = 0; 17 | 18 | for (0 .. 10) { 19 | $y && 20 | $x[1]++; 21 | 22 | $y && 23 | $x[0]++ && 24 | $x[1]++; 25 | 26 | $x[2]++ 27 | if $z; 28 | 29 | for (0 .. 2) { 30 | $x[3]++; 31 | } 32 | 33 | if ($y) { 34 | $x[4]++; 35 | } else { 36 | $y && $x[5]++; 37 | } 38 | 39 | my $p = $y & $z; 40 | 41 | $p &&= $y; 42 | $p &&= $z; 43 | my $q = 1; 44 | $q &&= $_; 45 | 46 | pas(); 47 | } 48 | 49 | sub pas { 50 | $y && $z 51 | } 52 | 53 | # print join(", ", @x), "\n"; 54 | -------------------------------------------------------------------------------- /tests/sort: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | 5 | my %sort = ( 6 | B => \&backwards, 7 | F => \&forwards 8 | ); 9 | 10 | sub backwards { 11 | return $b cmp $a; 12 | } 13 | 14 | sub forwards { 15 | return $a cmp $b; 16 | } 17 | 18 | sub GetAlgorithm { 19 | my ($alg) = @_; 20 | return $sort{$alg}; 21 | } 22 | 23 | my @list = qw( a d e c g ); 24 | 25 | # my $alg = GetAlgorithm(('B', 'F')[int(rand(2))]); 26 | my $alg = GetAlgorithm(('B', 'F')[0]); 27 | 28 | @list = sort {&{$alg}} @list; 29 | 30 | use Data::Dumper; 31 | 32 | print STDERR Dumper(\@list); 33 | 34 | package Failure; 35 | 36 | sub fail { 37 | my @x = 1 .. 5; 38 | my @y = sort { Failure->xyz( $a, $b ) } @x; 39 | } 40 | 41 | sub xyz { 42 | my $self = shift; 43 | my ($a, $b) = @_; 44 | $a <=> $b; 45 | } 46 | package main; 47 | 48 | my @l = Failure->fail; 49 | 50 | print STDERR Dumper(\@l); 51 | -------------------------------------------------------------------------------- /tests/inc_sub: -------------------------------------------------------------------------------- 1 | #!/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.010 11 | # __COVER__ skip_reason %+ not available before 5.10 12 | # __COVER__ skip_test 1 13 | # __COVER__ skip_reason depends too much on specific installed perl 14 | 15 | use lib (); 16 | 17 | BEGIN { 18 | lib->import( 19 | sub { 20 | print map("[$_]", @_), "\n"; 21 | return unless $_[1] eq "IncSub.pm"; 22 | my $fh; 23 | open $fh, "tests/IncSub.pm" or die $!; 24 | $fh 25 | } 26 | ) 27 | } 28 | 29 | use IncSub; 30 | 31 | BEGIN { "x" =~ /((?x))/; print "$+{x}\n" } # force Tie::Hash::NamedCapture 32 | 33 | IncSub::check 34 | -------------------------------------------------------------------------------- /tests/moose_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.010 || !(eval "use Moose 2; 23") 11 | # __COVER__ skip_reason Moose 2 not available or unreliable with Devel::Cover 12 | 13 | use strict; 14 | use warnings; 15 | 16 | package Cover_branch_bug; 17 | 18 | use Moose; 19 | has meep => ( isa => 'HashRef', is => 'rw' ); 20 | 21 | my $self = __PACKAGE__->new; 22 | 23 | $self->meep( { marp => 0 } ); 24 | print "meep contains " . $self->wagh . "\n"; 25 | 26 | $self->meep( { marp => 1 } ); 27 | print "meep contains " . $self->wagh . "\n"; 28 | 29 | sub wagh { 30 | my ( $self ) = @_; 31 | my $x = $self || 0; 32 | return $self->meep->{marp} || 0; 33 | # return $self || 0; 34 | } 35 | -------------------------------------------------------------------------------- /docs/BUGS: -------------------------------------------------------------------------------- 1 | - BEGIN and CHECK blocks and code in modules is not reported. 2 | 3 | - Doesn't play nicely with all of Perl's testsuite. 4 | 5 | - elsif and else coverage is reported on the same line as the if 6 | statement. This is because perl doesn't store the line number for the 7 | elsif and elses. For the same reason the following warning is 8 | reported on line 1 rather than line 2: 9 | 10 | perl -we 'if ($a) {} 11 | elsif ($a + 1) {}' 12 | Use of uninitialized value in addition (+) at -e line 1. 13 | 14 | - Pod coverage only reports data for modules, not top level scripts. 15 | This is a limitation in Pod::Coverage. 16 | 17 | - Pod coverage does not work well with source filters including Switch. 18 | Line numbers are reported incorrectly. 19 | 20 | - If an END block installs another END block it won't be covered. More 21 | generally, any code run after Devel::Cover's END block won't be covered. 22 | 23 | - Empty subs will be ignored in Perl 5.8.1. 24 | -------------------------------------------------------------------------------- /docs/RELEASE: -------------------------------------------------------------------------------- 1 | 1. Update Changes. 2 | - Add important changes. 3 | - Credit the author as appropriate. 4 | - Include github and RT numbers. 5 | 6 | 2. Check it in. 7 | $ git commit -m "Add Changes." Changes 8 | 9 | 3. Update Contributors. 10 | 11 | 4. Check it in. 12 | $ git commit -m "Update Contributors." Contributors 13 | 14 | 5. Update version number in Makefile.PL. 15 | 16 | 6. Check it in. 17 | $ git commit -m "Bump version number." Makefile.PL 18 | 19 | 7. Run basic tests. 20 | $ perl Makefile.PL && make 21 | $ make test 22 | 23 | 8. Test against all versions. 24 | $ make all_test 25 | 26 | 9. Return to base perl version. 27 | $ perl Makefile.PL && make 28 | 29 | 10. If there's a new stable release of perl: 30 | $ cpan Dist::Zilla 31 | $ cpan `dzil authordeps --missing` 32 | 33 | 11. Make the release. 34 | $ dzil release 35 | 36 | 12. Push the changes. 37 | - The dzil Git::Push plugin hangs for me 38 | $ git push && git push --tags 39 | -------------------------------------------------------------------------------- /utils/makeh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my $Command = { 14 | strip_criterion => sub { 15 | my ($command, $criterion, $file) = @_; 16 | my $t; 17 | local ($^I, @ARGV) = (".bak", $file); 18 | while (<>) { 19 | $t = index($_, "$criterion code") -3 if !defined $t || $t < 0; 20 | substr $_, $t, 7, "" 21 | if /^line err stmt/ .. /^--------/ and $t > -1 and length > $t; 22 | print; 23 | } 24 | }, 25 | }; 26 | 27 | sub main { 28 | my ($command) = @ARGV; 29 | die "No such command: $command" unless $Command->{$command}; 30 | $Command->{$command}->(@ARGV) 31 | } 32 | 33 | main 34 | -------------------------------------------------------------------------------- /tests/uncoverable: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ uncoverable_file tests/.uncoverable 11 | 12 | my $x = 1; 13 | my $y = 1; 14 | 15 | # uncoverable branch true 16 | # uncoverable condition left 17 | # uncoverable condition false 18 | if ($x && !$y) { 19 | $x++; # uncoverable statement 20 | # uncoverable statement 21 | z(); 22 | } 23 | 24 | # uncoverable branch true 25 | # uncoverable condition right 26 | # uncoverable condition false 27 | if (!$x && $y) { 28 | # uncoverable statement count:1 29 | # uncoverable statement count:2 30 | b(); b(); 31 | } 32 | 33 | sub z { 34 | # uncoverable subroutine 35 | $y++; # uncoverable statement 36 | } 37 | 38 | # uncoverable statement 39 | # uncoverable subroutine 40 | -------------------------------------------------------------------------------- /tests/cond_or.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | sub cond_dor { 14 | my ($x) = @_; 15 | 16 | $x->[18] //= undef; 17 | $x->[18] //= 0; 18 | $x->[18] //= 0; 19 | $x->[18] //= 1; 20 | $x->[18] //= 1; 21 | 22 | $x->[19] //= 1; 23 | $x->[19] //= 1; 24 | $x->[19] //= 0; 25 | $x->[19] //= undef; 26 | $x->[19] //= 1; 27 | 28 | $x->[20] = $x->[21] // undef; 29 | $x->[20] = $x->[21] // 0; 30 | $x->[20] = $x->[21] // 0; 31 | $x->[20] = $x->[21] // 1; 32 | $x->[20] = $x->[21] // 1; 33 | 34 | $x->[22] = $x->[22] // undef; 35 | $x->[22] = $x->[22] // 0; 36 | $x->[22] = $x->[22] // 0; 37 | $x->[22] = $x->[22] // 1; 38 | $x->[22] = $x->[22] // 1; 39 | } 40 | 41 | 1; 42 | -------------------------------------------------------------------------------- /utils/cpanmcover: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | my $moddir = glob "~/.cpanm/work"; 14 | my $covdir = glob "~/cpancover"; 15 | my $lnkdir = "$covdir/modules"; 16 | my $resdir = "$covdir/results"; 17 | 18 | mkdir $covdir, 0750 unless -d $covdir; 19 | mkdir $lnkdir, 0750 unless -d $lnkdir; 20 | mkdir $resdir, 0750 unless -d $resdir; 21 | 22 | for my $d (grep -d, <$moddir/*/*>) { 23 | print "Linking $d\n"; 24 | my ($e) = $d =~ m|/([^/]+)$| or die "Can't find module name"; 25 | my $new = "$lnkdir/$e"; 26 | unlink $new if -e $new; 27 | symlink $d => $new; 28 | } 29 | 30 | my $c; 31 | $c .= "cpancover -directory $lnkdir -outputdir $resdir "; 32 | $c .= "-outputfile index.html -report html_basic"; 33 | # $c .= " -force"; 34 | # $c .= " -redo_html"; 35 | print "running [$c]\n"; 36 | system $c; 37 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Html_Common.pm: -------------------------------------------------------------------------------- 1 | package Devel::Cover::Html_Common; 2 | BEGIN {require 5.006} 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | 8 | use Exporter; 9 | 10 | our @ISA = 'Exporter'; 11 | our @EXPORT_OK = 'launch'; 12 | 13 | sub launch { 14 | my ($package, $opt) = @_; 15 | 16 | my $outfile = "$opt->{outputdir}/$opt->{option}{outputfile}"; 17 | if (eval { require Browser::Open }) { 18 | Browser::Open::open_browser($outfile); 19 | } else { 20 | print STDERR "Devel::Cover: -launch requires Browser::Open\n"; 21 | } 22 | } 23 | 24 | =pod 25 | 26 | =head1 NAME 27 | 28 | Devel::Cover::Report::Html_Common - Common code for HTML reporters 29 | 30 | =head1 DESCRIPTION 31 | 32 | This module provides common functionality for HTML reporters. 33 | 34 | =head1 Functions 35 | 36 | =over 4 37 | 38 | =item launch 39 | 40 | Launch a browser to view the report. HTML reporters just need to import this 41 | function to enable the -launch flag for that report type. 42 | 43 | =back 44 | 45 | =head1 SEE ALSO 46 | 47 | Devel::Cover 48 | 49 | =cut 50 | 51 | 1; 52 | -------------------------------------------------------------------------------- /tests/readonly: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.008002 || !(eval "use Readonly; 23") 11 | # __COVER__ skip_reason Readonly not available 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Readonly; 17 | 18 | Readonly my $REGEXP_MATCH => '2'; 19 | my @lines = ( '1', '2', '3', 'A', 'B', 'c' ); 20 | 21 | sub test_readonly_coverage { 22 | # All branches executed. 23 | foreach my $line (@lines) { 24 | if ($line =~ /$REGEXP_MATCH/msx) { 25 | print "true ($line)\n"; 26 | } else { 27 | print "false ($line)\n"; 28 | } 29 | } 30 | } 31 | 32 | sub test_posix_regexp { 33 | # All branches executed. 34 | foreach my $line (@lines) { 35 | if ($line =~ /[[:upper:]]/msx) { 36 | print "true ($line)\n"; 37 | } else { 38 | print "false ($line)\n"; 39 | } 40 | } 41 | } 42 | 43 | test_readonly_coverage; 44 | test_posix_regexp; 45 | -------------------------------------------------------------------------------- /docs/cpancover: -------------------------------------------------------------------------------- 1 | How to set up cpancover 2 | 3 | Cpancover requires a bourne shell and docker, as well as a recent perl. The 4 | code requires 5.16.0 but earlier versions may work. 5 | 6 | Each module is built in an individual docker container. This should allow its 7 | resources to be constrained. In addition the docker container is killed after a 8 | certain time. 9 | 10 | I have only run this in Ubuntu 14.04. The docker version there, 0.9.1 (as of 11 | 31.05.2104) is insufficient. Version 0.11.1 is fine. I don't know about the 12 | versions inbetween. 13 | 14 | The latest version of docker can be installed on Ubuntu as follows: 15 | (see http://askubuntu.com/questions/472412/how-do-i-upgrade-docker) 16 | 17 | # wget -qO- https://get.docker.io/gpg | apt-key add - 18 | # echo deb http://get.docker.io/ubuntu docker main > /etc/apt/sources.list.d/docker.list 19 | # aptitude update 20 | # aptitude remove docker.io 21 | # aptitude install lxc-docker 22 | 23 | You may need to add yourself to the docker group. 24 | 25 | Jobs are run as follows: 26 | 27 | $ . ./utils/setup 28 | $ dc cpancover-latest | head -2000 | dc cpancover 29 | 30 | The top level html and json is generated with: 31 | 32 | $ dc cpancover-generate-html 33 | -------------------------------------------------------------------------------- /tests/dynamic_subs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | sub unused { 0 } 11 | sub empty { } 12 | 13 | sub gen { 14 | my $x = shift; 15 | sub { 16 | my $y = shift; 17 | return $x + $y if $y; 18 | } 19 | }; 20 | 21 | my $o = gen(1); 22 | my $p = $o->(7); 23 | my $q = $o->(8); 24 | my $r = gen(1)->(2); 25 | my $s = gen(3)->(4); 26 | my $t = gen(5)->(6); 27 | 28 | print "$p, $q, $r, $s, $t\n"; 29 | 30 | for my $func (qw(f1 f2 f3)) { 31 | no strict "refs"; 32 | *$func = sub { 33 | print "$func\n"; 34 | } 35 | } 36 | 37 | f1(); 38 | f2(); 39 | 40 | sub AUTOLOAD { 41 | my $func = $AUTOLOAD; 42 | $func =~ s/^.*:://; 43 | no strict "refs"; 44 | if ($func eq "add") { 45 | *$func = sub { 46 | print "Add!\n"; 47 | }; 48 | } else { 49 | *$func = sub { 50 | print "$func\n"; 51 | }; 52 | } 53 | goto &$func 54 | } 55 | 56 | add(); 57 | add(); 58 | add(); 59 | qaz(); 60 | wsx(); 61 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_xor_4.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition_xor_4; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Condition"; 16 | 17 | sub count { 4 } 18 | sub headers { [qw( l&&r l&&!r !l&&r !l&&!r )] } 19 | 20 | 1 21 | 22 | __END__ 23 | 24 | =head1 NAME 25 | 26 | Devel::Cover::Condition_xor_4 - Code coverage metrics for Perl 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Devel::Cover::Condition_xor_4; 31 | 32 | =head1 DESCRIPTION 33 | 34 | Module for storing condition coverage information for xor conditions. 35 | 36 | =head1 SEE ALSO 37 | 38 | Devel::Cover::Condition 39 | 40 | =head1 METHODS 41 | 42 | =head1 BUGS 43 | 44 | Huh? 45 | 46 | =head1 LICENCE 47 | 48 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 49 | 50 | This software is free. It is licensed under the same terms as Perl itself. 51 | 52 | The latest version of this software should be available from my homepage: 53 | http://www.pjcj.net 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_or_2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition_or_2; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Condition"; 16 | 17 | sub count { 2 } 18 | sub headers { [qw( l !l )] } 19 | 20 | 1 21 | 22 | __END__ 23 | 24 | =head1 NAME 25 | 26 | Devel::Cover::Condition_or_2 - Code coverage metrics for Perl 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Devel::Cover::Condition_or_2; 31 | 32 | =head1 DESCRIPTION 33 | 34 | Module for storing condition coverage information for or conditions 35 | where the right value is a constant. 36 | 37 | =head1 SEE ALSO 38 | 39 | Devel::Cover::Condition 40 | 41 | =head1 METHODS 42 | 43 | =head1 BUGS 44 | 45 | Huh? 46 | 47 | =head1 LICENCE 48 | 49 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 50 | 51 | This software is free. It is licensed under the same terms as Perl itself. 52 | 53 | The latest version of this software should be available from my homepage: 54 | http://www.pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_and_2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition_and_2; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Condition"; 16 | 17 | sub count { 2 } 18 | sub headers { [qw( l !l )] } 19 | 20 | 1 21 | 22 | __END__ 23 | 24 | =head1 NAME 25 | 26 | Devel::Cover::Condition_and_2 - Code coverage metrics for Perl 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Devel::Cover::Condition_and_2; 31 | 32 | =head1 DESCRIPTION 33 | 34 | Module for storing condition coverage information for and conditions 35 | where the right value is a constant. 36 | 37 | =head1 SEE ALSO 38 | 39 | Devel::Cover::Condition 40 | 41 | =head1 METHODS 42 | 43 | =head1 BUGS 44 | 45 | Huh? 46 | 47 | =head1 LICENCE 48 | 49 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 50 | 51 | This software is free. It is licensed under the same terms as Perl itself. 52 | 53 | The latest version of this software should be available from my homepage: 54 | http://www.pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /t/internal/criteria.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Warn; 6 | 7 | if ($] < 5.008000) { 8 | plan skip_all => "Test requires perl 5.8.0 or greater"; 9 | } if ($] == 5.015006) { 10 | plan skip_all => "5.15.6 throws too many erroneous warnings"; 11 | } else { 12 | require Devel::Cover; 13 | Devel::Cover->import(qw( -silent 1 )); 14 | plan tests => 5; 15 | } 16 | 17 | Devel::Cover::set_coverage("none"); 18 | is Devel::Cover::get_coverage(), 19 | "", 20 | "Set coverage to none empties coverage"; 21 | 22 | Devel::Cover::set_coverage("all"); 23 | is Devel::Cover::get_coverage(), 24 | "branch condition path pod statement subroutine time", 25 | "Set coverage to all fills coverage"; 26 | 27 | Devel::Cover::remove_coverage("path"); 28 | is Devel::Cover::get_coverage(), 29 | "branch condition pod statement subroutine time", 30 | "Removing path coverage works"; 31 | 32 | warning_like { Devel::Cover::add_coverage("does_not_exist") } 33 | qr/Devel::Cover: Unknown coverage criterion "does_not_exist" ignored./, 34 | "Adding non-existent coverage warns"; 35 | is Devel::Cover::get_coverage(), 36 | "branch condition pod statement subroutine time", 37 | "Adding non-existent coverage has no effect"; 38 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_or_3.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition_or_3; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Condition"; 16 | 17 | sub count { 3 } 18 | sub headers { [qw( l !l&&r !l&&!r )] } 19 | 20 | 1 21 | 22 | __END__ 23 | 24 | =head1 NAME 25 | 26 | Devel::Cover::Condition_or_3 - Code coverage metrics for Perl 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Devel::Cover::Condition_or_3; 31 | 32 | =head1 DESCRIPTION 33 | 34 | Module for storing condition coverage information for or conditions 35 | where the right value is a constant. 36 | 37 | =head1 SEE ALSO 38 | 39 | Devel::Cover::Condition 40 | 41 | =head1 METHODS 42 | 43 | =head1 BUGS 44 | 45 | Huh? 46 | 47 | =head1 LICENCE 48 | 49 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 50 | 51 | This software is free. It is licensed under the same terms as Perl itself. 52 | 53 | The latest version of this software should be available from my homepage: 54 | http://www.pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_and_3.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition_and_3; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Condition"; 16 | 17 | sub count { 3 } 18 | sub headers { [qw( !l l&&!r l&&r )] } 19 | 20 | 1 21 | 22 | __END__ 23 | 24 | =head1 NAME 25 | 26 | Devel::Cover::Condition_and_3 - Code coverage metrics for Perl 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Devel::Cover::Condition_and_3; 31 | 32 | =head1 DESCRIPTION 33 | 34 | Module for storing condition coverage information for or conditions 35 | where the right value is a constant. 36 | 37 | =head1 SEE ALSO 38 | 39 | Devel::Cover::Condition 40 | 41 | =head1 METHODS 42 | 43 | =head1 BUGS 44 | 45 | Huh? 46 | 47 | =head1 LICENCE 48 | 49 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 50 | 51 | This software is free. It is licensed under the same terms as Perl itself. 52 | 53 | The latest version of this software should be available from my homepage: 54 | http://www.pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Report/Html.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Report::Html; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Report::Html_minimal"; 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =head1 NAME 22 | 23 | Devel::Cover::Report::Html - HTML backend for Devel::Cover 24 | 25 | =head1 SYNOPSIS 26 | 27 | cover -report html 28 | 29 | =head1 DESCRIPTION 30 | 31 | This module provides a HTML reporting mechanism for coverage data. It 32 | is designed to be called from the C program. This is an empty 33 | class derived from the default HTML output module, 34 | Devel::Cover::Report::Html_minimal. 35 | 36 | =head1 SEE ALSO 37 | 38 | Devel::Cover 39 | 40 | =head1 BUGS 41 | 42 | Huh? 43 | 44 | =head1 LICENCE 45 | 46 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 47 | 48 | This software is free. It is licensed under the same terms as Perl itself. 49 | 50 | The latest version of this software should be available from my homepage: 51 | http://www.pjcj.net 52 | 53 | =cut 54 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 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 DC::Test::Dist::M1; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | sub new { 16 | bless {}, shift 17 | } 18 | 19 | sub m1 { 20 | my $self = shift; 21 | if (@_) { 22 | $self->{m1} = shift; 23 | } 24 | $self->{m1} 25 | } 26 | 27 | sub m2 { 28 | my $self = shift; 29 | if (@_) { 30 | $self->{m2} = shift; 31 | } 32 | $self->{m2} 33 | } 34 | 35 | 1 36 | 37 | __END__ 38 | 39 | =head1 NAME 40 | 41 | DC::Test::Dist::M1 - Devel::Cover distribution test submodule 42 | 43 | =head1 SYNOPSIS 44 | 45 | This module is only used as a Devel::Cover test of a complete distribution. 46 | 47 | =head1 DESCRIPTION 48 | 49 | None. 50 | 51 | =head1 LICENCE 52 | 53 | Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 54 | 55 | This software is free. It is licensed under the same terms as Perl itself. 56 | 57 | The latest version of this software should be available from my homepage: 58 | http://www.pjcj.net 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 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 DC::Test::Dist; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use DC::Test::Dist::M1; 16 | 17 | sub new { 18 | bless {}, shift 19 | } 20 | 21 | sub d1 { 22 | my $self = shift; 23 | if (@_) { 24 | $self->{d1} = shift; 25 | } 26 | $self->{d1} 27 | } 28 | 29 | sub d2 { 30 | my $self = shift; 31 | if (@_) { 32 | $self->{d2} = shift; 33 | } 34 | $self->{d2} 35 | } 36 | 37 | 1 38 | 39 | __END__ 40 | 41 | =head1 NAME 42 | 43 | DC::Test::Dist - Devel::Cover distribution test module 44 | 45 | =head1 SYNOPSIS 46 | 47 | This module is only used as a Devel::Cover test of a complete distribution. 48 | 49 | =head1 DESCRIPTION 50 | 51 | None. 52 | 53 | =head1 LICENCE 54 | 55 | Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 56 | 57 | This software is free. It is licensed under the same terms as Perl itself. 58 | 59 | The latest version of this software should be available from my homepage: 60 | http://www.pjcj.net 61 | 62 | =cut 63 | -------------------------------------------------------------------------------- /tests/dbm_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.008005 || !(eval "use DBM::Deep; 23") 11 | # __COVER__ skip_reason DBM::Deep not available 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Test::More; 17 | 18 | use DBM::Deep; 19 | 20 | my $db = DBM::Deep->new( "temp.db" ); 21 | $db->{1} = 1; 22 | 23 | my $h = { 1 => 1 }; 24 | 25 | sub testdbm { 26 | my ( $p ) = @_; 27 | 28 | if( exists $db->{$p} ) { 29 | return "dbm: exists"; 30 | } else { 31 | return "dbm: does not exist"; 32 | } 33 | } 34 | 35 | sub testh { 36 | my ( $p ) = @_; 37 | 38 | if( exists $h->{$p} ) { 39 | return "h: exists"; 40 | } else { 41 | return "h: does not exist"; 42 | } 43 | } 44 | 45 | is( testdbm( 1 ), "dbm: exists", "key exists in dbm" ); 46 | is( testdbm( 2 ), "dbm: does not exist", "key does not exist in dbm" ); 47 | 48 | is( testh( 1 ), "h: exists", "key exists in h" ); 49 | is( testh( 2 ), "h: does not exist", "key does not exist in h" ); 50 | 51 | unlink "temp.db"; 52 | 53 | done_testing(); 54 | -------------------------------------------------------------------------------- /tests/eval_use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | if ($] == 5.008007) { 16 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 17 | exit; 18 | } 19 | 20 | my $run_test = sub { 21 | my $test = shift; 22 | 23 | $test->run_command($test->test_command); 24 | 25 | $test->{test_parameters} .= " -merge 1"; 26 | 27 | $test->{test_file_parameters} = "5"; 28 | $test->run_command($test->test_command); 29 | 30 | $test->{test_file_parameters} = "7"; 31 | $test->run_command($test->test_command); 32 | 33 | $test->{test_file_parameters} = "0"; 34 | $test->run_command($test->test_command); 35 | }; 36 | 37 | my $test = Devel::Cover::Test->new( 38 | "eval2", 39 | db_name => "complex_eval_use", 40 | golden_test => "eval_use.t", 41 | run_test => $run_test, 42 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 43 | tests => sub { $_[0] - 24 }, # number of lines deleted above 44 | ); 45 | 46 | $test->run_test; 47 | no warnings; 48 | $test # for create_gold 49 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Subroutine.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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::Subroutine; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Criterion"; 16 | 17 | sub uncoverable { $_[0][2] } 18 | sub covered { $_[0][0] } 19 | sub total { 1 } 20 | sub percentage { $_[0][0] ? 100 : 0 } 21 | sub error { $_[0][0] xor !$_[0][2] } 22 | sub name { $_[0][1] } 23 | sub criterion { 'subroutine' } 24 | 25 | 1 26 | 27 | __END__ 28 | 29 | =head1 NAME 30 | 31 | Devel::Cover::Statement - Code coverage metrics for Perl 32 | 33 | =head1 SYNOPSIS 34 | 35 | use Devel::Cover::Statement; 36 | 37 | =head1 DESCRIPTION 38 | 39 | Module for storing subroutine coverage information. 40 | 41 | =head1 SEE ALSO 42 | 43 | Devel::Cover::Criterion 44 | 45 | =head1 METHODS 46 | 47 | =head1 BUGS 48 | 49 | Huh? 50 | 51 | =head1 LICENCE 52 | 53 | Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 54 | 55 | This software is free. It is licensed under the same terms as Perl itself. 56 | 57 | The latest version of this software should be available from my homepage: 58 | http://www.pjcj.net 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Statement.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Statement; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Criterion"; 16 | 17 | sub val { $_[0][0] } 18 | sub uncoverable { $_[0][1] } 19 | sub covered { $_[0][0] } 20 | sub total { 1 } 21 | sub percentage { $_[0][0] ? 100 : 0 } 22 | sub error { $_[0][0] xor !$_[0][1] } 23 | sub criterion { 'statement' } 24 | 25 | 26 | 1 27 | 28 | __END__ 29 | 30 | =head1 NAME 31 | 32 | Devel::Cover::Statement - Code coverage metrics for Perl 33 | 34 | =head1 SYNOPSIS 35 | 36 | use Devel::Cover::Statement; 37 | 38 | =head1 DESCRIPTION 39 | 40 | Module for storing statement coverage information. 41 | 42 | =head1 SEE ALSO 43 | 44 | Devel::Cover::Criterion 45 | 46 | =head1 METHODS 47 | 48 | =head1 BUGS 49 | 50 | Huh? 51 | 52 | =head1 LICENCE 53 | 54 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 55 | 56 | This software is free. It is licensed under the same terms as Perl itself. 57 | 58 | The latest version of this software should be available from my homepage: 59 | http://www.pjcj.net 60 | 61 | =cut 62 | -------------------------------------------------------------------------------- /tests/eval_merge.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | # print "QQQ\n"; 16 | 17 | if ($] == 5.008007) { 18 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 19 | exit; 20 | } 21 | 22 | # print "RRR\n"; 23 | 24 | my $run_test = sub { 25 | my $test = shift; 26 | 27 | # print "UUU\n"; 28 | 29 | $test->{test_file_parameters} = "0"; 30 | $test->run_command($test->test_command); 31 | 32 | # print "VVV\n"; 33 | 34 | $test->{test_parameters} .= " -merge 1"; 35 | 36 | $test->{test_file_parameters} = "1"; 37 | $test->run_command($test->test_command); 38 | }; 39 | 40 | my $runs = 2; 41 | 42 | my $test = Devel::Cover::Test->new( 43 | "eval_merge", 44 | db_name => "complex_eval_merge", 45 | golden_test => "eval_merge.t", 46 | run_test => $run_test, 47 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 48 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 49 | ); 50 | 51 | # print "SSS\n"; 52 | 53 | $test->run_test; 54 | 55 | # print "TTT\n"; 56 | 57 | no warnings; 58 | $test # for create_gold 59 | -------------------------------------------------------------------------------- /test_output/cover/trivial.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/trivial 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/trivial 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 my $x = 1; 31 | 32 | 33 | -------------------------------------------------------------------------------- /tests/eval_merge_sep.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | # print "QQQ\n"; 16 | 17 | if ($] == 5.008007) { 18 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 19 | exit; 20 | } 21 | 22 | # print "RRR\n"; 23 | 24 | my $run_test = sub { 25 | my $test = shift; 26 | 27 | # print "UUU\n"; 28 | 29 | $test->{test} = "eval_merge_0"; 30 | $test->run_command($test->test_command); 31 | 32 | # print "VVV\n"; 33 | 34 | $test->{test_parameters} .= " -merge 1"; 35 | 36 | $test->{test} = "eval_merge_1"; 37 | $test->run_command($test->test_command); 38 | }; 39 | 40 | my $runs = 2; 41 | 42 | my $test = Devel::Cover::Test->new( 43 | "eval_merge_sep", 44 | db_name => "complex_eval_merge_sep", 45 | golden_test => "eval_merge_sep.t", 46 | run_test => $run_test, 47 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 48 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 49 | ); 50 | 51 | # print "SSS\n"; 52 | 53 | $test->run_test; 54 | 55 | # print "TTT\n"; 56 | 57 | no warnings; 58 | $test # for create_gold 59 | -------------------------------------------------------------------------------- /tests/eval_sub.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | if ($] == 5.008007) { 16 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 17 | exit; 18 | } 19 | 20 | my $run_test = sub { 21 | my $test = shift; 22 | 23 | $test->{test_file_parameters} = "5"; 24 | $test->run_command($test->test_command); 25 | 26 | $test->{test_parameters} .= " -merge 1"; 27 | 28 | $test->{test_file_parameters} = "5"; 29 | $test->run_command($test->test_command); 30 | 31 | $test->{test_file_parameters} = "7"; 32 | $test->run_command($test->test_command); 33 | 34 | $test->{test_file_parameters} = "0"; 35 | $test->run_command($test->test_command); 36 | }; 37 | 38 | my $runs = 4; 39 | 40 | my $test = Devel::Cover::Test->new( 41 | "eval3", 42 | db_name => "complex_eval_sub", 43 | golden_test => "eval_sub.t", 44 | run_test => $run_test, 45 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 46 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 47 | ); 48 | 49 | $test->run_test; 50 | no warnings; 51 | $test # for create_gold 52 | -------------------------------------------------------------------------------- /tests/md5.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use File::Copy; 14 | 15 | use Devel::Cover::Inc; 16 | use Devel::Cover::Test; 17 | 18 | if ($] == 5.008007) { 19 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 20 | exit; 21 | } 22 | 23 | my $base = $Devel::Cover::Inc::Base; 24 | 25 | my $t = "md5"; 26 | my $ft = "$base/tests/$t"; 27 | my $fg = "$base/tests/trivial"; 28 | 29 | my $run_test = sub { 30 | my $test = shift; 31 | 32 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 33 | open T, ">>$ft" or die "Cannot open $ft: $!"; 34 | print T "# blah blah\n"; 35 | close T or die "Cannot close $ft: $!"; 36 | $test->run_command($test->test_command); 37 | 38 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 39 | $test->{test_parameters} .= " -merge 1"; 40 | $test->run_command($test->test_command); 41 | }; 42 | 43 | my $test = Devel::Cover::Test->new( 44 | $t, 45 | db_name => "complex_$t", 46 | run_test => $run_test, 47 | end => sub { unlink $ft }, 48 | delay_after_run => 0.50, 49 | ); 50 | 51 | $test->run_test; 52 | no warnings; 53 | $test # for create_gold 54 | -------------------------------------------------------------------------------- /test_output/cover/xor_constant_fold.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/xor_constant_fold 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/xor_constant_fold 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 xor 0; 31 | 32 | 33 | -------------------------------------------------------------------------------- /test_output/cover/padrange.5.008001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/padrange 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 my @s; 31 | 11 1 for (@s) {} 32 | 33 | 34 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Condition; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Branch"; 16 | 17 | sub pad { $_[0][0][$_] ||= 0 for 0 .. $_[0]->count - 1 } 18 | sub text { "$_[0][1]{left} $_[0][1]{op} $_[0][1]{right}" } 19 | sub type { $_[0][1]{type} } 20 | sub count { require Carp; Carp::confess("count() must be overridden") } 21 | sub headers { require Carp; Carp::confess("headers() must be overridden") } 22 | sub criterion { 'condition' } 23 | 24 | 1 25 | 26 | __END__ 27 | 28 | =head1 NAME 29 | 30 | Devel::Cover::Condition - Code coverage metrics for Perl 31 | 32 | =head1 SYNOPSIS 33 | 34 | use Devel::Cover::Condition; 35 | 36 | =head1 DESCRIPTION 37 | 38 | Module for storing condition coverage information. 39 | 40 | =head1 SEE ALSO 41 | 42 | Devel::Cover::Criterion 43 | 44 | =head1 METHODS 45 | 46 | =head1 BUGS 47 | 48 | Huh? 49 | 50 | =head1 LICENCE 51 | 52 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 53 | 54 | This software is free. It is licensed under the same terms as Perl itself. 55 | 56 | The latest version of this software should be available from my homepage: 57 | http://www.pjcj.net 58 | 59 | =cut 60 | -------------------------------------------------------------------------------- /test_output/cover/v-58x.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/v-58x 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/v-58x 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use 5.006; 31 | 11 32 | 12 1 my $x = 1; 33 | 34 | 35 | -------------------------------------------------------------------------------- /test_output/cover/padrange.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/padrange 66.6 n/a n/a n/a 66.6 8 | Total 66.6 n/a n/a n/a 66.6 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 my @s; 31 | 11 1 for (@s) {} 32 | *** 0 33 | 34 | 35 | -------------------------------------------------------------------------------- /tests/change.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use File::Copy; 14 | 15 | use Devel::Cover::Inc; 16 | use Devel::Cover::Test; 17 | 18 | if ($] == 5.008007) { 19 | eval "use Test::More skip_all => 'Crashes 5.8.7'"; 20 | exit; 21 | } 22 | 23 | my $base = $Devel::Cover::Inc::Base; 24 | 25 | my $t = "change"; 26 | my $ft = "$base/tests/$t"; 27 | my $fg = "$base/tests/trivial"; 28 | 29 | my $run_test = sub { 30 | my $test = shift; 31 | 32 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 33 | $test->run_command($test->test_command); 34 | 35 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 36 | open T, ">>$ft" or die "Cannot open $ft: $!"; 37 | print T <<'EOT'; 38 | sub new_sub { 39 | my $y = 1; 40 | } 41 | 42 | new_sub; 43 | EOT 44 | close T or die "Cannot close $ft: $!"; 45 | 46 | $test->{test_parameters} .= " -merge 1"; 47 | $test->run_command($test->test_command); 48 | }; 49 | 50 | my $test = Devel::Cover::Test->new( 51 | $t, 52 | db_name => "complex_$t", 53 | run_test => $run_test, 54 | end => sub { unlink $ft }, 55 | no_report => 0, 56 | delay_after_run => 0.50, 57 | ); 58 | 59 | $test->run_test; 60 | no warnings; 61 | $test # for create_gold 62 | -------------------------------------------------------------------------------- /test_output/cover/padrange.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/padrange 50.0 n/a n/a n/a 50.0 8 | Total 50.0 n/a n/a n/a 50.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 my @s; 31 | 11 1 for (@s) {} 32 | *** 0 33 | *** 0 34 | 35 | 36 | -------------------------------------------------------------------------------- /test_output/cover/md5.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | Devel::Cover: Deleting old coverage for changed file tests/md5 3 | 4 | 5 | ------------------------------------------ ------ ------ ------ ------ ------ 6 | File stmt bran cond sub total 7 | ------------------------------------------ ------ ------ ------ ------ ------ 8 | tests/md5 100.0 n/a n/a n/a 100.0 9 | Total 100.0 n/a n/a n/a 100.0 10 | ------------------------------------------ ------ ------ ------ ------ ------ 11 | 12 | 13 | Run: ... 14 | Perl version: ... 15 | OS: ... 16 | Start: ... 17 | Finish: ... 18 | 19 | Run: ... 20 | Perl version: ... 21 | OS: ... 22 | Start: ... 23 | Finish: ... 24 | 25 | tests/md5 26 | 27 | line err stmt bran cond sub code 28 | 1 #!/usr/bin/perl 29 | 2 30 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 31 | 4 32 | 5 # This software is free. It is licensed under the same terms as Perl itself. 33 | 6 34 | 7 # The latest version of this software should be available from my homepage: 35 | 8 # http://www.pjcj.net 36 | 9 37 | 10 1 my $x = 1; 38 | 39 | 40 | -------------------------------------------------------------------------------- /test_output/cover/pod.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------------------------------------------------------- ------ ------ 5 | File pod total 6 | --------------------------------------------------------------- ------ ------ 7 | tests/Module1.pm 50.0 50.0 8 | tests/PodMod.pm 66.6 66.6 9 | tests/pod n/a n/a 10 | Total 60.0 60.0 11 | --------------------------------------------------------------- ------ ------ 12 | 13 | 14 | Run: ... 15 | Perl version: ... 16 | OS: ... 17 | Start: ... 18 | Finish: ... 19 | 20 | Uncovered Subroutines 21 | --------------------- 22 | 23 | Subroutine Count Pod Location 24 | ---------- ----- --- ------------------- 25 | _aa 0 tests/Module1.pm:14 26 | xx 0 tests/Module1.pm:20 27 | yy 0 1 tests/Module1.pm:25 28 | zz 0 0 tests/Module1.pm:29 29 | 30 | 31 | Uncovered Subroutines 32 | --------------------- 33 | 34 | Subroutine Count Pod Location 35 | ---------- ----- --- ------------------ 36 | vv 0 1 tests/PodMod.pm:12 37 | ww 0 0 tests/PodMod.pm:13 38 | yy 0 1 tests/PodMod.pm:14 39 | 40 | 41 | Uncovered Subroutines 42 | --------------------- 43 | 44 | Subroutine Count Location 45 | ---------- ----- ------------ 46 | xx 0 tests/pod:25 47 | 48 | 49 | -------------------------------------------------------------------------------- /utils/create_gold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | require 5.6.1; 11 | 12 | use strict; 13 | use warnings; 14 | 15 | # VERSION 16 | 17 | use blib; 18 | 19 | use Config; 20 | exit if $Config{useithreads}; 21 | 22 | use Devel::Cover::Test; 23 | 24 | my @tests = @ARGV; 25 | 26 | mkdir "test_output" unless -d "test_output"; 27 | mkdir "test_output/cover" unless -d "test_output/cover"; 28 | 29 | unless (@tests) { 30 | opendir D, "tests" or die "Cannot opendir tests: $!"; 31 | for my $t (sort readdir D) { 32 | next unless -f "tests/$t"; 33 | next if $t =~ /\.(pm|pl|uncoverable|version|org|bak)$/; 34 | next if $t =~ /~$/; 35 | push @tests, $t; 36 | } 37 | closedir D or die "Cannot closedir tests: $!"; 38 | } 39 | 40 | for my $test (@tests) { 41 | my $e = "t/e2e"; 42 | my ($file) = grep -e, "$e/$test", "$e/a$test.t"; 43 | $file ||= $test; 44 | print STDERR "creating golden results for $test: "; 45 | # print "requiring [$file]\n"; 46 | die "Can't fork" unless defined(my $pid = fork); 47 | if ($pid) { 48 | waitpid $pid, 0; 49 | } else { 50 | no warnings "redefine"; 51 | local *Devel::Cover::Test::run_test = sub {}; 52 | my $t = require $file or die "Can't require $file: $!"; 53 | $t->create_gold && print STDERR "\n"; 54 | exit; 55 | } 56 | } 57 | -------------------------------------------------------------------------------- /test_output/cover/exec.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/exec 66.6 n/a n/a n/a 66.6 8 | Total 66.6 n/a n/a n/a 66.6 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/exec 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2007-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 $x = 1; 31 | 11 32 | 12 1 exec "echo foo"; 33 | 13 34 | 14 *** 0 die "Unreachable"; 35 | 36 | 37 | -------------------------------------------------------------------------------- /test_output/cover/pod_nocp.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------------------------------------------------------- ------ ------ 5 | File pod total 6 | --------------------------------------------------------------- ------ ------ 7 | tests/Module1.pm 50.0 50.0 8 | tests/PodMod.pm 33.3 33.3 9 | tests/pod_nocp n/a n/a 10 | Total 40.0 40.0 11 | --------------------------------------------------------------- ------ ------ 12 | 13 | 14 | Run: ... 15 | Perl version: ... 16 | OS: ... 17 | Start: ... 18 | Finish: ... 19 | 20 | Uncovered Subroutines 21 | --------------------- 22 | 23 | Subroutine Count Pod Location 24 | ---------- ----- --- ------------------- 25 | _aa 0 tests/Module1.pm:14 26 | xx 0 tests/Module1.pm:20 27 | yy 0 1 tests/Module1.pm:25 28 | zz 0 0 tests/Module1.pm:29 29 | 30 | 31 | Uncovered Subroutines 32 | --------------------- 33 | 34 | Subroutine Count Pod Location 35 | ---------- ----- --- ------------------ 36 | vv 0 1 tests/PodMod.pm:12 37 | ww 0 0 tests/PodMod.pm:13 38 | yy 0 0 tests/PodMod.pm:14 39 | 40 | 41 | Uncovered Subroutines 42 | --------------------- 43 | 44 | Subroutine Count Location 45 | ---------- ----- ----------------- 46 | xx 0 tests/pod_nocp:25 47 | 48 | 49 | -------------------------------------------------------------------------------- /test_output/cover/statement.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/statement 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/statement 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 my $pi = 3.14159; my $r = 4; 31 | 1 32 | 11 1 my $c = 2 * $pi * $r; 33 | 12 1 my $a = $pi * $r * $r; 34 | 35 | 36 | -------------------------------------------------------------------------------- /utils/bisect.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # set -x 4 | 5 | perl=~/g/perl/perl 6 | bisect=${perl}-bisect 7 | dc=~/g/perl/Devel--Cover 8 | inst=/usr/local/pkg/bisect 9 | blead=$inst/bin/perl 10 | 11 | case "$1" in 12 | "launch") 13 | shift 14 | if [ -z "$1" ]; then 15 | echo "uasge: $0 launch your_test" 16 | exit 1 17 | fi 18 | test="$1" 19 | shift 20 | cd $perl 21 | git checkout blead 22 | # $bisect/Porting/bisect.pl -Dnoextensions=Encode "$@" -- $dc/$0 "$test" 23 | $bisect/Porting/bisect.pl -Dusedevel -Uversiononly -Dprefix=$inst "$@" -- $dc/$0 "$test" 24 | ;; 25 | "test") 26 | $blead -v 27 | ret=$? 28 | [ $ret -gt 127 ] && ret=127 29 | exit $ret 30 | ;; 31 | "bug_and") 32 | rm -rf $inst 33 | cd $perl 34 | make install 35 | # ./perl installperl -v 36 | cd $dc 37 | $blead Makefile.PL 38 | make 39 | make 40 | make out TEST=uncoverable 41 | grep -F '0 -0 1 $x and $y' uncoverable.out 42 | ret=$? 43 | [ $ret -gt 127 ] && ret=127 44 | exit $ret 45 | [ $ret -eq 0 ] && exit 1 46 | exit 0 47 | ;; 48 | *) 49 | echo cd $perl 50 | echo git clean -dxf 51 | echo cp -a $perl $bisect 52 | echo cd $dc 53 | echo edit $0 and add your_test 54 | echo $0 launch your_test [--start v5.14.0 --end v5.15.0] 55 | ;; 56 | esac 57 | 58 | exit 59 | 60 | #if you need to invert the exit code, replace the exit in your test with: 61 | [ $ret -eq 0 ] && exit 1 62 | exit 0 63 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Dumper.pm: -------------------------------------------------------------------------------- 1 | # This file is part of Devel::Cover. 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 | # Author of this file: Olivier Mengué 9 | 10 | package # Private module 11 | Devel::Cover::Dumper; 12 | 13 | use strict qw( vars subs ); # no refs 14 | use warnings; 15 | 16 | # VERSION 17 | 18 | sub import { 19 | my $caller = caller; 20 | if (defined &{"${caller}::Dumper"} && \&{"${caller}::Dumper"} != \&Dumper) { 21 | require Carp; 22 | Carp::croak("Data::Dumper previously imported. " . 23 | "Use Devel::Cover::Dumper instead."); 24 | } 25 | *{"${caller}::Dumper"} = \&Dumper; 26 | } 27 | 28 | sub Dumper { 29 | require Data::Dumper; 30 | local $Data::Dumper::Indent = 1; 31 | local $Data::Dumper::Sortkeys = 1; 32 | Data::Dumper::Dumper(@_); 33 | } 34 | 35 | 1 36 | 37 | __END__ 38 | 39 | =encoding utf8 40 | 41 | =head1 NAME 42 | 43 | Devel::Cover::Dumper - Internal module for debugging purposes 44 | 45 | =head1 SYNOPSIS 46 | 47 | use Devel::Cover::Dumper; 48 | 49 | print Dumper $x; 50 | 51 | =head1 DESCRIPTION 52 | 53 | Wrapper around Data::Dumper::Dumper. 54 | 55 | =head1 SEE ALSO 56 | 57 | Devel::Cover 58 | 59 | =head1 METHODS 60 | 61 | =head1 BUGS 62 | 63 | Huh? 64 | 65 | =head1 LICENCE 66 | 67 | Copyright 2012, Olivier Mengué 68 | 69 | This software is free. It is licensed under the same terms as Perl itself. 70 | 71 | The latest version of this software should be available from my homepage: 72 | http://www.pjcj.net 73 | 74 | =cut 75 | -------------------------------------------------------------------------------- /test_output/cover/taint.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/taint 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/taint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 use lib "tests"; 33 | 13 34 | 14 use Taint; 35 | 15 36 | 16 1 print "taint\n"; 37 | 38 | 39 | -------------------------------------------------------------------------------- /test_output/cover/v-58x.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/v-58x 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/v-58x 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use 5.006; 31 | 1 32 | 1 33 | 11 34 | 12 1 my $x = 1; 35 | 36 | 37 | Covered Subroutines 38 | ------------------- 39 | 40 | Subroutine Count Location 41 | ---------- ----- -------------- 42 | BEGIN 1 tests/v-58x:10 43 | 44 | 45 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Pod.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Pod; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Criterion"; 16 | 17 | BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available. 18 | 19 | sub uncoverable { $_[0][2] } 20 | sub covered { $_[0][0] ? 1 : 0 } 21 | sub total { 1 } 22 | sub percentage { $_[0][0] ? 100 : 0 } 23 | sub error { $_[0][0] xor !$_[0][2] } 24 | sub criterion { 'pod' } 25 | 26 | sub calculate_summary { 27 | my $self = shift; 28 | my ($db, $file) = @_; 29 | 30 | return unless $INC{"Pod/Coverage.pm"}; 31 | 32 | my $s = $db->{summary}; 33 | 34 | $self->aggregate($s, $file, 'total', $self->total); 35 | $self->aggregate($s, $file, 'covered', 1) 36 | if $self->covered; 37 | $self->aggregate($s, $file, 'error', $self->error); 38 | } 39 | 40 | 1 41 | 42 | __END__ 43 | 44 | =head1 NAME 45 | 46 | Devel::Cover::Pod - Code coverage metrics for Perl 47 | 48 | =head1 SYNOPSIS 49 | 50 | use Devel::Cover::Pod; 51 | 52 | =head1 DESCRIPTION 53 | 54 | Module for storing pod coverage information. 55 | 56 | =head1 SEE ALSO 57 | 58 | Devel::Cover::Criterion 59 | 60 | =head1 METHODS 61 | 62 | =head1 BUGS 63 | 64 | Huh? 65 | 66 | =head1 LICENCE 67 | 68 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 69 | 70 | This software is free. It is licensed under the same terms as Perl itself. 71 | 72 | The latest version of this software should be available from my homepage: 73 | http://www.pjcj.net 74 | 75 | =cut 76 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Time.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Time; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Criterion"; 16 | 17 | sub uncoverable { 0 } 18 | sub covered { ${$_[0]} } 19 | sub total { 1 } 20 | sub percentage { ${$_[0]} ? 100 : 0 } 21 | sub error { 0 } 22 | 23 | sub calculate_summary { 24 | my $self = shift; 25 | my ($db, $file) = @_; 26 | 27 | $db->{summary}{$file}{time}{total} += $$self; 28 | $db->{summary}{Total}{time}{total} += $$self; 29 | } 30 | 31 | sub calculate_percentage { 32 | my $class = shift; 33 | my ($db, $s) = @_; 34 | my $t = $db->{summary}{Total}{time}{total}; 35 | $s->{percentage} = $t ? $s->{total} * 100 / $t : 100; 36 | } 37 | 38 | 1 39 | 40 | __END__ 41 | 42 | =head1 NAME 43 | 44 | Devel::Cover::Time - Code coverage metrics for Perl 45 | 46 | =head1 SYNOPSIS 47 | 48 | use Devel::Cover::Time; 49 | 50 | =head1 DESCRIPTION 51 | 52 | Module for storing time coverage information. 53 | 54 | =head1 SEE ALSO 55 | 56 | Devel::Cover::Criterion 57 | 58 | =head1 METHODS 59 | 60 | =head2 new 61 | 62 | my $db = Devel::Cover::DB->new(db => "my_coverage_db"); 63 | 64 | Contructs the DB from the specified database. 65 | 66 | =head1 BUGS 67 | 68 | Huh? 69 | 70 | =head1 LICENCE 71 | 72 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 73 | 74 | This software is free. It is licensed under the same terms as Perl itself. 75 | 76 | The latest version of this software should be available from my homepage: 77 | http://www.pjcj.net 78 | 79 | =cut 80 | -------------------------------------------------------------------------------- /test_output/cover/module_import.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/Module_import.pm 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/Module_import.pm 19 | 20 | line err stmt bran cond sub code 21 | 1 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 22 | 2 23 | 3 # This software is free. It is licensed under the same terms as Perl itself. 24 | 4 25 | 5 # The latest version of this software should be available from my homepage: 26 | 6 # http://www.pjcj.net 27 | 7 28 | 8 package Module_import; 29 | 9 30 | 10 sub import { 31 | 11 1 1 print "Module_import\n"; 32 | 12 } 33 | 13 34 | 14 1 35 | 36 | 37 | Covered Subroutines 38 | ------------------- 39 | 40 | Subroutine Count Location 41 | ---------- ----- ------------------------- 42 | import 1 tests/Module_import.pm:11 43 | 44 | 45 | -------------------------------------------------------------------------------- /t/regexp/regexp_eval.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More tests => 1; 4 | 5 | # This tests against what is basically a perl bug. When evaluating 6 | # code within a regular expression, the state of the regular 7 | # expression engine may not be altered, i.e. no regex match may be 8 | # performed within a regular expression. 9 | # 10 | # The following code doesn't do that, but entering the eval within the 11 | # regular expression involves a nextstate OP. We hook, among other 12 | # things, into those opcodes, and execute some of our own 13 | # code. Devel::Cover::use_file, to be precise. That function currently 14 | # uses regular expressions, and therefore breaks shit. 15 | # 16 | # We currently avoid calling use_file at all within regexp evals. This 17 | # test makes sure we actually do, and will yell at us if we ever start 18 | # doing it again. 19 | # 20 | # This bug in perl is now fixed with commit 91332126 and part of perl 21 | # 5.13.6. If we ever wanted to use regexp matching from use_file or 22 | # some place, that's called while collecting data, again we could pull 23 | # a hack similar to the aforementioned commit in Cover.xs so we 24 | # continue to work on perls older than 5.13.6. 25 | 26 | 'x' =~ m{ (?: ((??{ 'x' })) )? }x; 27 | 28 | # on debugging perls we'd already have hit an assertion failure 29 | # here. We don't do "pass 'no assertion fail'" tho. I don't know if 30 | # that might mess up $1 for the next test. We also have to use $1 31 | # instead of capturing in a lexical, as that tends to fail rather 32 | # differently. 33 | 34 | # on non-debugging perls, the above match tends to succeed, and only 35 | # rarely segfaults. Therefore we also make sure that the result is 36 | # correct. If we hit the bug, it tends to either contain complete 37 | # garbage, (parts of) some random constants from the perl interpreter, 38 | # or segfaults completely when invoking the get magic on it. 39 | 40 | is $1, 'x'; 41 | -------------------------------------------------------------------------------- /test_output/cover/bigint.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/bigint 100.0 50.0 n/a n/a 75.0 8 | Total 100.0 50.0 n/a n/a 75.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/bigint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 use Math::BigInt ":constant"; 34 | 14 35 | 15 1 my $x = 1; 36 | 16 *** 1 50 print $x if 1 >= $x; 37 | 38 | 39 | Branches 40 | -------- 41 | 42 | line err % true false branch 43 | ----- --- ------ ------ ------ ------ 44 | 16 *** 50 1 0 if \('+1') >= $x 45 | 46 | 47 | -------------------------------------------------------------------------------- /test_output/cover/cop.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/cop 66.6 n/a n/a 0.0 50.0 8 | Total 66.6 n/a n/a 0.0 50.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/cop 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 use lib "tests"; 34 | 14 35 | 15 *** 1 0 $SIG{__WARN__} = sub { die @_ }; 36 | *** 0 37 | 16 1 require COP; 38 | 39 | 40 | Uncovered Subroutines 41 | --------------------- 42 | 43 | Subroutine Count Location 44 | ---------- ----- ------------ 45 | __ANON__ 0 tests/cop:15 46 | 47 | 48 | -------------------------------------------------------------------------------- /test_output/cover/change.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | Devel::Cover: Deleting old coverage for changed file tests/change 3 | 4 | 5 | ------------------------------------------ ------ ------ ------ ------ ------ 6 | File stmt bran cond sub total 7 | ------------------------------------------ ------ ------ ------ ------ ------ 8 | tests/change 100.0 n/a n/a 100.0 100.0 9 | Total 100.0 n/a n/a 100.0 100.0 10 | ------------------------------------------ ------ ------ ------ ------ ------ 11 | 12 | 13 | Run: ... 14 | Perl version: ... 15 | OS: ... 16 | Start: ... 17 | Finish: ... 18 | 19 | Run: ... 20 | Perl version: ... 21 | OS: ... 22 | Start: ... 23 | Finish: ... 24 | 25 | tests/change 26 | 27 | line err stmt bran cond sub code 28 | 1 #!/usr/bin/perl 29 | 2 30 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 31 | 4 32 | 5 # This software is free. It is licensed under the same terms as Perl itself. 33 | 6 34 | 7 # The latest version of this software should be available from my homepage: 35 | 8 # http://www.pjcj.net 36 | 9 37 | 10 1 my $x = 1; 38 | 11 sub new_sub { 39 | 12 1 1 my $y = 1; 40 | 13 } 41 | 14 42 | 15 1 new_sub; 43 | 44 | 45 | Covered Subroutines 46 | ------------------- 47 | 48 | Subroutine Count Location 49 | ---------- ----- --------------- 50 | new_sub 1 tests/change:12 51 | 52 | 53 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/File.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::DB::File; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Devel::Cover::Criterion; 16 | 17 | use Devel::Cover::Dumper; 18 | 19 | sub calculate_summary { 20 | my $self = shift; 21 | my ($db, $file, $options) = @_; 22 | 23 | my $s = $db->{summary}{$file} ||= {}; 24 | 25 | for my $criterion ($self->items) { 26 | next unless $options->{$criterion}; 27 | for my $location ($self->$criterion()->locations) { 28 | for my $cover (@$location) { 29 | $cover->calculate_summary($db, $file); 30 | } 31 | } 32 | } 33 | } 34 | 35 | sub calculate_percentage { 36 | my $self = shift; 37 | my ($db, $s) = @_; 38 | 39 | # print STDERR Dumper $s; 40 | 41 | for my $criterion ($self->items) { 42 | next unless exists $s->{$criterion}; 43 | my $c = "Devel::Cover::\u$criterion"; 44 | # print "$c\n"; 45 | $c->calculate_percentage($db, $s->{$criterion}); 46 | } 47 | Devel::Cover::Criterion->calculate_percentage($db, $s->{total}); 48 | 49 | # print STDERR Dumper $s; 50 | } 51 | 52 | 1 53 | 54 | __END__ 55 | 56 | =head1 NAME 57 | 58 | Devel::Cover::DB::File - Code coverage metrics for Perl 59 | 60 | =head1 SYNOPSIS 61 | 62 | use Devel::Cover::DB::File; 63 | 64 | =head1 DESCRIPTION 65 | 66 | =head1 SEE ALSO 67 | 68 | Devel::Cover 69 | 70 | =head1 METHODS 71 | 72 | =head1 BUGS 73 | 74 | Huh? 75 | 76 | =head1 LICENCE 77 | 78 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 79 | 80 | This software is free. It is licensed under the same terms as Perl itself. 81 | 82 | The latest version of this software should be available from my homepage: 83 | http://www.pjcj.net 84 | 85 | =cut 86 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO/Storable.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 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::DB::IO::Storable; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Storable; 14 | 15 | # VERSION 16 | 17 | sub new { 18 | my $class = shift; 19 | my $self = { @_ }; 20 | bless $self, $class 21 | } 22 | 23 | sub read { 24 | my $self = shift; 25 | my ($file) = @_; 26 | Storable::lock_retrieve($file) 27 | } 28 | 29 | sub write { 30 | my $self = shift; 31 | my ($data, $file) = @_; 32 | Storable::lock_nstore($data, $file); 33 | $self 34 | } 35 | 36 | 1 37 | 38 | __END__ 39 | 40 | =head1 NAME 41 | 42 | Devel::Cover::DB::IO::Storable - Storable based IO routines for Devel::Cover::DB 43 | 44 | =head1 SYNOPSIS 45 | 46 | use Devel::Cover::DB::IO::Storable; 47 | 48 | my $io = Devel::Cover::DB::IO::Storable->new; 49 | my $data = $io->read($file); 50 | $io->write($data, $file); 51 | 52 | =head1 DESCRIPTION 53 | 54 | This module provides Storable based IO routines for Devel::Cover::DB. 55 | 56 | =head1 SEE ALSO 57 | 58 | Devel::Cover 59 | 60 | =head1 METHODS 61 | 62 | =head2 new 63 | 64 | my $io = Devel::Cover::DB::IO::Storable->new; 65 | 66 | Contructs the IO object. 67 | 68 | =head2 read 69 | 70 | my $data = $io->read($file); 71 | 72 | Returns a perl data structure representing the data read from $file. 73 | 74 | =head2 write 75 | 76 | $io->write($data, $file); 77 | 78 | Writes $data to $file in the format specified when creating $io. 79 | 80 | =head1 BUGS 81 | 82 | Huh? 83 | 84 | =head1 LICENCE 85 | 86 | Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 87 | 88 | This software is free. It is licensed under the same terms as Perl itself. 89 | 90 | The latest version of this software should be available from my homepage: 91 | http://www.pjcj.net 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /test_output/cover/t1.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/t1 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/t1 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 1 my @x; 34 | 14 35 | 15 sub xx { 36 | 16 1 1 $x[shift]++; 37 | 17 } 38 | 18 39 | 19 1 xx(4); 40 | 41 | 42 | Covered Subroutines 43 | ------------------- 44 | 45 | Subroutine Count Location 46 | ---------- ----- ----------- 47 | xx 1 tests/t1:16 48 | 49 | 50 | -------------------------------------------------------------------------------- /tests/cond_or: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.008 || $^O eq "cygwin" 11 | # __COVER__ skip_reason Busted on 5.6 and cygwin 12 | 13 | use strict; 14 | use warnings; 15 | 16 | my @x; 17 | 18 | my $y = 1; 19 | my $z = 0; 20 | $::foo = 17; 21 | 22 | if ($] >= 5.009) { 23 | $ENV{PATH} = "/bin"; 24 | system "pwd"; 25 | use lib "tests"; 26 | my $file = "cond_or.pl"; 27 | unless (my $return = do $file) { 28 | die "couldn't parse $file: $@" if $@; 29 | die "couldn't do $file: $!" unless defined $return; 30 | die "couldn't run $file" unless $return; 31 | } 32 | } 33 | 34 | for my $i (0 .. 10) { 35 | $y || 36 | $x[1]++; 37 | 38 | $y || 39 | $x[0]++ || 40 | $x[1]++; 41 | 42 | $x[2]++ 43 | unless $z; 44 | 45 | for (0 .. 2) { 46 | $x[3]++; 47 | } 48 | 49 | if ($z) { 50 | $x[4]++; 51 | } else { 52 | $x[5]++; 53 | } 54 | 55 | my $p = $y || $z; 56 | my $q = $z || $y; 57 | my $r = $i || "qqq"; 58 | my $s = $i || []; 59 | my $t = $y | $z; 60 | my $u = $y || 0; 61 | my $v = $y || undef; 62 | my $w = $z || 0; 63 | 64 | $p ||= $y; 65 | $p ||= $z; 66 | $x[ 6] ||= $y; 67 | $x[ 7] ||= $z; 68 | $x[ 8] ||= 1; 69 | $x[ 9] ||= {}; 70 | $x[10] ||= \"foo"; 71 | $x[11] ||= \$y; 72 | $x[12] ||= \*STDIO; 73 | $x[13] ||= sub { 1 }; 74 | $x[14] ||= *::foo{SCALAR}; 75 | $x[15] ||= *STDIO{IO}; 76 | $x[16] ||= bless {}, "XXX"; 77 | $x[17] ||= $i == 1; 78 | $w ||= ref($i) eq "SCALAR"; 79 | $x[18] ||= <<"EOD"; 80 | blah 81 | EOD 82 | cond_dor(\@x) if exists &cond_dor; 83 | sub { $x[19] ||= 1 }; 84 | } 85 | 86 | # print join(", ", @x), "\n"; 87 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Report/Json.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2014, Paul Johnson (paul@pjcj.net) 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::Report::Json; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Devel::Cover::DB::IO::JSON; 16 | use Devel::Cover::Dumper; # For debugging 17 | 18 | sub add_runs 19 | { 20 | my ($db) = @_; 21 | my @runs; 22 | for my $r (sort {$a->{start} <=> $b->{start}} $db->runs) { 23 | push @runs, { 24 | map { $_ => $r->$_ } 25 | qw( run perl OS dir name version abstract start finish ) 26 | }; 27 | } 28 | \@runs 29 | } 30 | 31 | sub report 32 | { 33 | my ($pkg, $db, $options) = @_; 34 | 35 | my %options = map { $_ => 1 } grep !/path|time/, $db->all_criteria, "force"; 36 | $db->calculate_summary(%options); 37 | 38 | my $json = { 39 | runs => add_runs($db), 40 | summary => $db->{summary}, 41 | }; 42 | # print "JSON: ", Dumper $json; 43 | print "JSON sent to $options->{outputdir}/cover.json\n"; 44 | 45 | my $io = Devel::Cover::DB::IO::JSON->new(options => "pretty"); 46 | $io->write($json, "$options->{outputdir}/cover.json"); 47 | } 48 | 49 | 1 50 | 51 | __END__ 52 | 53 | =head1 NAME 54 | 55 | Devel::Cover::Report::Json - JSON backend for Devel::Cover 56 | 57 | =head1 SYNOPSIS 58 | 59 | cover -report json 60 | 61 | =head1 DESCRIPTION 62 | 63 | This module provides JSON output for coverage data. 64 | It is designed to be called from the C program. 65 | 66 | =head1 SEE ALSO 67 | 68 | Devel::Cover 69 | 70 | =head1 BUGS 71 | 72 | Huh? 73 | 74 | =head1 LICENCE 75 | 76 | Copyright 2014, Paul Johnson (paul@pjcj.net) 77 | 78 | This software is free. It is licensed under the same terms as Perl itself. 79 | 80 | The latest version of this software should be available from my homepage: 81 | http://www.pjcj.net 82 | 83 | =cut 84 | -------------------------------------------------------------------------------- /test_output/cover/pod.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------------------------------------------------------- ------ ------ 5 | File pod total 6 | --------------------------------------------------------------- ------ ------ 7 | tests/Module1.pm 50.0 50.0 8 | tests/PodMod.pm 66.6 66.6 9 | tests/pod n/a n/a 10 | Total 60.0 60.0 11 | --------------------------------------------------------------- ------ ------ 12 | 13 | 14 | Run: ... 15 | Perl version: ... 16 | OS: ... 17 | Start: ... 18 | Finish: ... 19 | 20 | Uncovered Subroutines 21 | --------------------- 22 | 23 | Subroutine Count Pod Location 24 | ---------- ----- --- ------------------- 25 | _aa 0 tests/Module1.pm:14 26 | xx 0 tests/Module1.pm:20 27 | yy 0 1 tests/Module1.pm:25 28 | zz 0 0 tests/Module1.pm:29 29 | 30 | 31 | Covered Subroutines 32 | ------------------- 33 | 34 | Subroutine Count Pod Location 35 | ---------- ----- --- ------------------ 36 | BEGIN 1 tests/PodMod.pm:10 37 | 38 | Uncovered Subroutines 39 | --------------------- 40 | 41 | Subroutine Count Pod Location 42 | ---------- ----- --- ------------------ 43 | vv 0 1 tests/PodMod.pm:12 44 | ww 0 0 tests/PodMod.pm:13 45 | yy 0 1 tests/PodMod.pm:14 46 | 47 | 48 | Covered Subroutines 49 | ------------------- 50 | 51 | Subroutine Count Location 52 | ---------- ----- ------------ 53 | BEGIN 1 tests/pod:14 54 | BEGIN 1 tests/pod:15 55 | BEGIN 1 tests/pod:17 56 | BEGIN 1 tests/pod:19 57 | 58 | Uncovered Subroutines 59 | --------------------- 60 | 61 | Subroutine Count Location 62 | ---------- ----- ------------ 63 | xx 0 tests/pod:25 64 | 65 | 66 | -------------------------------------------------------------------------------- /test_output/cover/pod_nocp.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------------------------------------------------------- ------ ------ 5 | File pod total 6 | --------------------------------------------------------------- ------ ------ 7 | tests/Module1.pm 50.0 50.0 8 | tests/PodMod.pm 33.3 33.3 9 | tests/pod_nocp n/a n/a 10 | Total 40.0 40.0 11 | --------------------------------------------------------------- ------ ------ 12 | 13 | 14 | Run: ... 15 | Perl version: ... 16 | OS: ... 17 | Start: ... 18 | Finish: ... 19 | 20 | Uncovered Subroutines 21 | --------------------- 22 | 23 | Subroutine Count Pod Location 24 | ---------- ----- --- ------------------- 25 | _aa 0 tests/Module1.pm:14 26 | xx 0 tests/Module1.pm:20 27 | yy 0 1 tests/Module1.pm:25 28 | zz 0 0 tests/Module1.pm:29 29 | 30 | 31 | Covered Subroutines 32 | ------------------- 33 | 34 | Subroutine Count Pod Location 35 | ---------- ----- --- ------------------ 36 | BEGIN 1 tests/PodMod.pm:10 37 | 38 | Uncovered Subroutines 39 | --------------------- 40 | 41 | Subroutine Count Pod Location 42 | ---------- ----- --- ------------------ 43 | vv 0 1 tests/PodMod.pm:12 44 | ww 0 0 tests/PodMod.pm:13 45 | yy 0 0 tests/PodMod.pm:14 46 | 47 | 48 | Covered Subroutines 49 | ------------------- 50 | 51 | Subroutine Count Location 52 | ---------- ----- ----------------- 53 | BEGIN 1 tests/pod_nocp:14 54 | BEGIN 1 tests/pod_nocp:15 55 | BEGIN 1 tests/pod_nocp:17 56 | BEGIN 1 tests/pod_nocp:19 57 | 58 | Uncovered Subroutines 59 | --------------------- 60 | 61 | Subroutine Count Location 62 | ---------- ----- ----------------- 63 | xx 0 tests/pod_nocp:25 64 | 65 | 66 | -------------------------------------------------------------------------------- /test_output/cover/deparse.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/deparse 66.6 n/a n/a 0.0 50.0 8 | Total 66.6 n/a n/a 0.0 50.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/deparse 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl -l 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 use B::Deparse; 34 | 14 35 | 15 my $xx = sub { 36 | 16 *** 0 0 print "xx"; 37 | 17 1 }; 38 | 18 39 | 19 1 print B::Deparse->new->coderef2text($xx) 40 | 41 | 42 | Uncovered Subroutines 43 | --------------------- 44 | 45 | Subroutine Count Location 46 | ---------- ----- ---------------- 47 | __ANON__ 0 tests/deparse:16 48 | 49 | 50 | -------------------------------------------------------------------------------- /test_output/cover/moose_basic.5.010000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/moose_basic 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/moose_basic 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") 31 | 11 # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover 32 | 12 33 | 13 package Foo; 34 | 14 1 1 use Moose; 35 | 1 36 | 1 37 | 15 1 __PACKAGE__->meta->make_immutable; 38 | 39 | 40 | Covered Subroutines 41 | ------------------- 42 | 43 | Subroutine Count Location 44 | ---------- ----- -------------------- 45 | BEGIN 1 tests/moose_basic:14 46 | 47 | 48 | -------------------------------------------------------------------------------- /utils/Devel/Cover/BuildUtils.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2010-2014, Paul Johnson (paul@pjcj.net) 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::BuildUtils; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Exporter; 16 | 17 | our @ISA = "Exporter"; 18 | our @EXPORT_OK = qw(find_prove cpus nice_cpus prove_command); 19 | 20 | sub find_prove { 21 | my $perl = $^X; 22 | unless (-x $perl) { 23 | my ($dir) = grep -x "$_/$perl", split /:/, $ENV{PATH}; 24 | $perl = "$dir/$perl"; 25 | } 26 | 27 | eval { $perl = readlink($perl) || $perl }; 28 | # print "perl is [$perl]\n"; 29 | my ($dir) = $perl =~ m|(.*)/[^/]+|; 30 | my ($prove) = grep -x, <$dir/prove*>; 31 | 32 | print "prove is in $dir\n"; 33 | 34 | $prove 35 | } 36 | 37 | sub cpus { 38 | my $cpus = 1; 39 | eval { chomp ($cpus = `grep -c processor /proc/cpuinfo`); }; 40 | $cpus 41 | } 42 | 43 | sub nice_cpus { 44 | $ENV{DEVEL_COVER_CPUS} || do { 45 | my $cpus = cpus; 46 | $cpus-- if $cpus > 3; 47 | $cpus-- if $cpus > 6; 48 | $cpus 49 | } 50 | } 51 | 52 | sub prove_command { 53 | my $prove = find_prove or return; 54 | my $cpus = nice_cpus; 55 | "$prove -brj$cpus t" 56 | } 57 | 58 | __END__ 59 | 60 | =head1 NAME 61 | 62 | Devel::Cover::BuildUtils - Build utility functions for Devel::Cover 63 | 64 | =head1 SYNOPSIS 65 | 66 | use Devel::Cover::BuildUtils "find_prove"; 67 | 68 | =head1 DESCRIPTION 69 | 70 | Build utility functions for Devel::Cover. 71 | 72 | =head1 SEE ALSO 73 | 74 | Devel::Cover 75 | 76 | =head1 METHODS 77 | 78 | =head1 BUGS 79 | 80 | Huh? 81 | 82 | =head1 LICENCE 83 | 84 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 85 | 86 | This software is free. It is licensed under the same terms as Perl itself. 87 | 88 | The latest version of this software should be available from my homepage: 89 | http://www.pjcj.net 90 | 91 | =cut 92 | -------------------------------------------------------------------------------- /utils/install/System.pm: -------------------------------------------------------------------------------- 1 | # Copyright 1999 - 2000 by Paul Johnson (paul@pjcj.net) 2 | 3 | # documentation at __END__ 4 | 5 | # Original author: Paul Johnson 6 | # Created: Fri 12 Mar 1999 10:25:51 am 7 | 8 | use strict; 9 | 10 | require 5.004; 11 | 12 | package System; 13 | 14 | use Exporter (); 15 | use vars qw($VERSION @ISA @EXPORT); 16 | 17 | $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker 18 | 19 | @ISA = ("Exporter"); 20 | @EXPORT = ("sys", "dsys"); 21 | 22 | my $Command = 0; 23 | my $Errors = 0; 24 | my $Verbose = 0; 25 | 26 | sub import { 27 | my $class = shift; 28 | my $args = "@_"; 29 | $Command = $args =~ /\bcommand\b/i; 30 | $Errors = $args =~ /\berror\b/i; 31 | $Verbose = $args =~ /\bverbose\b/i; 32 | $Command ||= $Verbose; 33 | $Errors ||= $Verbose; 34 | $class->export_to_level(1, "sys" ) if $args =~ /\bsys\b/i; 35 | $class->export_to_level(1, "dsys") if $args =~ /\bdsys\b/i; 36 | } 37 | 38 | sub sys { 39 | my (@command) = @_; 40 | local $| = 1; 41 | print "@command"; # if $Command; 42 | my $rc = 0xffff & system @command; 43 | print "\n" if $Command && !$rc && !$Verbose; 44 | ret($rc); 45 | } 46 | 47 | sub dsys { 48 | die "@_ failed" if sys @_; 49 | } 50 | 51 | sub ret { 52 | my ($rc) = @_; 53 | printf " returned %#04x: ", $rc if $Errors && $rc; 54 | if ($rc == 0) { 55 | print "ran with normal exit\n" if $Verbose; 56 | } elsif ($rc == 0xff00) { 57 | print "command failed: $!\n" if $Errors; 58 | } elsif ($rc > 0x80) { 59 | $rc >>= 8; 60 | print "ran with non-zero exit status $rc\n" if $Errors; 61 | } else { 62 | print "ran with " if $Errors; 63 | if ($rc & 0x80) { 64 | $rc &= ~0x80; 65 | print "coredump from " if $Errors; 66 | } 67 | print "signal $rc\n" if $Errors; 68 | } 69 | $rc; 70 | } 71 | 72 | 1 73 | 74 | __END__ 75 | 76 | =head1 NAME 77 | 78 | System - run a system command and check the result 79 | 80 | =head1 SYNOPSIS 81 | 82 | use System "command, verbose, errors"; 83 | sys qw(ls -al); 84 | 85 | =head1 DESCRIPTION 86 | 87 | The sys function runs a system command, checks result, and comments on 88 | it. 89 | 90 | =cut 91 | -------------------------------------------------------------------------------- /test_output/cover/redefine_sub.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/redefine_sub 100.0 100.0 n/a 100.0 100.0 8 | Total 100.0 100.0 n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/redefine_sub 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 sub s1 { 24 | 4 2 2 my $t = shift; 25 | 5 2 100 if ($t > 5) { 26 | 6 1 print 5; 27 | 7 } else { 28 | 8 1 print $t; 29 | 9 } 30 | 10 } 31 | 11 32 | 12 1 my $c = *main::s1{CODE}; 33 | 13 34 | 14 *main::s1 = sub { 35 | 15 2 2 print "extra"; 36 | 16 2 &$c(@_); 37 | 17 1 }; 38 | 18 39 | 19 1 s1(1); 40 | 20 1 s1(7); 41 | 42 | 43 | Branches 44 | -------- 45 | 46 | line err % true false branch 47 | ----- --- ------ ------ ------ ------ 48 | 5 100 1 1 if ($t > 5) { } 49 | 50 | 51 | Covered Subroutines 52 | ------------------- 53 | 54 | Subroutine Count Location 55 | ---------- ----- --------------------- 56 | __ANON__ 2 tests/redefine_sub:15 57 | s1 2 tests/redefine_sub:4 58 | 59 | 60 | -------------------------------------------------------------------------------- /test_output/cover/t1.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/t1 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/t1 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 my @x; 38 | 14 39 | 15 sub xx { 40 | 16 1 1 $x[shift]++; 41 | 17 } 42 | 18 43 | 19 1 xx(4); 44 | 45 | 46 | Covered Subroutines 47 | ------------------- 48 | 49 | Subroutine Count Location 50 | ---------- ----- ----------- 51 | BEGIN 1 tests/t1:10 52 | BEGIN 1 tests/t1:11 53 | xx 1 tests/t1:16 54 | 55 | 56 | -------------------------------------------------------------------------------- /test_output/cover/eval_nested.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/eval_nested 100.0 n/a 50.0 100.0 77.7 8 | Total 100.0 n/a 50.0 100.0 77.7 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/eval_nested 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 1 2 eval "eval q[ sub config { {} } ]"; 34 | 2 35 | 14 36 | 15 *** 1 50 my $e1 = config() || {}; 37 | 16 *** 1 50 my $e2 = config()->{mail} || {}; 38 | 39 | 40 | Conditions 41 | ---------- 42 | 43 | or 2 conditions 44 | 45 | line err % l !l expr 46 | ----- --- ------ ------ ------ ---- 47 | 15 *** 50 1 0 config() || {} 48 | 16 *** 50 0 1 config()->{'mail'} || {} 49 | 50 | 51 | Covered Subroutines 52 | ------------------- 53 | 54 | Subroutine Count Location 55 | ---------- ----- -------------------- 56 | config 2 tests/eval_nested:13 57 | 58 | 59 | -------------------------------------------------------------------------------- /test_output/cover/destroy.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/destroy 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/destroy 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 package Destroy; 31 | 11 32 | 12 1 1 sub new { bless {}, shift } 33 | 13 34 | 14 1 my $x; 35 | 15 36 | 16 sub DESTROY { 37 | 17 1 1 $x++; 38 | 18 1 $x++; 39 | 19 } 40 | 20 41 | 21 package main; 42 | 22 43 | 23 1 my $d = Destroy->new; 44 | 45 | 46 | Covered Subroutines 47 | ------------------- 48 | 49 | Subroutine Count Location 50 | ---------- ----- ---------------- 51 | DESTROY 1 tests/destroy:17 52 | new 1 tests/destroy:12 53 | 54 | 55 | -------------------------------------------------------------------------------- /test_output/cover/skip.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/skip 83.3 50.0 n/a 100.0 72.7 8 | Total 83.3 50.0 n/a 100.0 72.7 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/skip 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 sub main { 31 | 11 1 1 my ($debug) = @_; 32 | 12 1 print "main\n"; 33 | 13 *** 1 50 print "debug1\n" if $debug; 34 | 14 *** 1 50 if ($debug) { 35 | 15 *** 0 print "debug2\n"; 36 | 16 } 37 | 17 } 38 | 18 39 | 19 1 main 0; 40 | 41 | 42 | Branches 43 | -------- 44 | 45 | line err % true false branch 46 | ----- --- ------ ------ ------ ------ 47 | 13 *** 50 0 1 if $debug 48 | 14 *** 50 0 1 if ($debug) 49 | 50 | 51 | Covered Subroutines 52 | ------------------- 53 | 54 | Subroutine Count Location 55 | ---------- ----- ------------- 56 | main 1 tests/skip:11 57 | 58 | 59 | -------------------------------------------------------------------------------- /test_output/cover/taint.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/taint 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/taint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 1 1 use lib "tests"; 37 | 1 38 | 1 39 | 13 40 | 14 1 1 use Taint; 41 | 1 42 | 1 43 | 15 44 | 16 1 print "taint\n"; 45 | 46 | 47 | Covered Subroutines 48 | ------------------- 49 | 50 | Subroutine Count Location 51 | ---------- ----- -------------- 52 | BEGIN 1 tests/taint:10 53 | BEGIN 1 tests/taint:11 54 | BEGIN 1 tests/taint:12 55 | BEGIN 1 tests/taint:14 56 | 57 | 58 | -------------------------------------------------------------------------------- /test_output/cover/overload_bool2.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/overload_bool2 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/overload_bool2 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 { 34 | 14 1 package Cat; 35 | 15 36 | 16 use overload (bool => "meh"); 37 | 17 38 | 18 1 1 sub meh { 1 } 39 | 19 } 40 | 20 41 | 21 1 my $string = "hi"; 42 | 22 1 my $x = bless \$string, "Cat"; 43 | 23 44 | 24 1 my $fn = eval 'require $x'; 45 | 46 | 47 | Covered Subroutines 48 | ------------------- 49 | 50 | Subroutine Count Location 51 | ---------- ----- ----------------------- 52 | meh 1 tests/overload_bool2:18 53 | 54 | 55 | -------------------------------------------------------------------------------- /utils/mail_contributors: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # Copyright 2013-2014, Paul Johnson (paul@pjcj.net) 4 | 5 | # This software is free. It is licensed under the same terms as Perl itself. 6 | 7 | # The latest version of this software should be available from my homepage: 8 | # http://www.pjcj.net 9 | 10 | # Run as: perl -C utils/mail_contributors < Contributors 11 | # Note *** Please don't run this - it was a one off for the first publication 12 | # *** of the Contributors (née Authors) file. 13 | 14 | use 5.16.3; 15 | use warnings; 16 | 17 | use Email::Stuffer; 18 | 19 | sub main { 20 | while (<>) { 21 | chomp; 22 | next unless /\@/; 23 | # say; 24 | sleep 10; 25 | my @parts = split / /; 26 | my $email = $parts[-1]; 27 | my $line = $_; 28 | my $body = <<"EOM"; 29 | Hello, 30 | 31 | I'm contacting you because you are one of the Authors of Devel::Cover. 32 | 33 | Thank you! 34 | 35 | Over 70 people have contributed to Devel::Cover over the years, and I have 36 | finally done something I should have done years ago. I have created an 37 | Authors file, and you are in it. 38 | 39 | But before I publish the file I want to make sure that you are happy to be a 40 | part of it. Your entry will read: 41 | 42 | $line 43 | 44 | If you are happy for this entry to be a part of the Devel::Cover Authors file 45 | then you don't need to do anything. (But feel free to explicitly confirm.) 46 | If you don't want to be mentioned, or you would like the entry to be changed 47 | at all, please let me know. 48 | 49 | I plan to make a new release with this Authors file included in a couple of 50 | weeks or so, so please let me know by then. 51 | 52 | And thank you once more for your contribution. Without you, Devel::Cover 53 | wouldn't be what it is today. 54 | 55 | With regards, 56 | 57 | Paul 58 | 59 | -- 60 | Paul Johnson - paul\@pjcj.net 61 | EOM 62 | eval { 63 | Email::Stuffer->from ('Paul Johnson ') 64 | ->to ($email) 65 | ->subject ("Devel::Cover Authors File") 66 | ->text_body($body) 67 | ->send_or_die; 68 | }; 69 | if ($@) { 70 | say "Failed to send mail <$line>\n$@" 71 | } else { 72 | say "Sent mail <$line>" 73 | } 74 | } 75 | } 76 | 77 | main 78 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 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::DB::IO; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | my $Format; 16 | 17 | BEGIN { 18 | $Format = "Sereal" if eval "use Sereal::Decoder; use Sereal::Encoder; 1"; 19 | $Format = "JSON" if !$Format and eval "use JSON; 1"; 20 | $Format = "JSON" if !$Format and eval "use JSON::PP; 1"; 21 | $Format = "Storable" if !$Format and eval "use Storable; 1"; 22 | die "Can't load either JSON or Storable" unless $Format; 23 | } 24 | 25 | sub new { 26 | my $class = shift; 27 | 28 | my $format = $ENV{DEVEL_COVER_DB_FORMAT} || $Format; 29 | ($format) = $format =~ /(.*)/; # die tainting 30 | die "Devel::Cover: Unrecognised DB format: $format" 31 | unless $format =~ /^(?:Storable|JSON|Sereal)$/; 32 | 33 | $class .= "::$format"; 34 | eval "use $class; 1" or die "Devel::Cover: $@"; 35 | 36 | $class->new(options => $ENV{DEVEL_COVER_IO_OPTIONS} || "", @_) 37 | } 38 | 39 | 1 40 | 41 | __END__ 42 | 43 | =head1 NAME 44 | 45 | Devel::Cover::DB::IO - IO routines for Devel::Cover::DB 46 | 47 | =head1 SYNOPSIS 48 | 49 | use Devel::Cover::DB::IO; 50 | 51 | my $io = Devel::Cover::DB::IO->new(format => "JSON"); 52 | my $data = $io->read($file); 53 | $io->write($data, $file); 54 | 55 | =head1 DESCRIPTION 56 | 57 | This module provides IO routines for Devel::Cover::DB. 58 | 59 | =head1 SEE ALSO 60 | 61 | Devel::Cover 62 | 63 | =head1 METHODS 64 | 65 | =head2 new 66 | 67 | my $io = Devel::Cover::DB::IO->new(format => "JSON"); 68 | 69 | Contructs the IO object. 70 | 71 | =head2 read 72 | 73 | my $data = $io->read($file); 74 | 75 | Returns a perl data structure representing the data read from $file. 76 | 77 | =head2 write 78 | 79 | $io->write($data, $file); 80 | 81 | Writes $data to $file in the format specified when creating $io. 82 | 83 | =head1 BUGS 84 | 85 | Huh? 86 | 87 | =head1 LICENCE 88 | 89 | Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 90 | 91 | This software is free. It is licensed under the same terms as Perl itself. 92 | 93 | The latest version of this software should be available from my homepage: 94 | http://www.pjcj.net 95 | 96 | =cut 97 | -------------------------------------------------------------------------------- /test_output/cover/bigint.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/bigint 100.0 50.0 n/a 100.0 93.7 8 | Total 100.0 50.0 n/a 100.0 93.7 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/bigint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 1 use Math::BigInt ":constant"; 38 | 1 39 | 1 40 | 14 41 | 15 1 my $x = 1; 42 | 16 *** 1 50 print $x if 1 >= $x; 43 | 44 | 45 | Branches 46 | -------- 47 | 48 | line err % true false branch 49 | ----- --- ------ ------ ------ ------ 50 | 16 *** 50 1 0 if \(undef) >= $x 51 | 52 | 53 | Covered Subroutines 54 | ------------------- 55 | 56 | Subroutine Count Location 57 | ---------- ----- --------------- 58 | BEGIN 1 tests/bigint:10 59 | BEGIN 1 tests/bigint:11 60 | BEGIN 1 tests/bigint:13 61 | 62 | 63 | -------------------------------------------------------------------------------- /test_output/cover/special_blocks.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/special_blocks 100.0 n/a n/a n/a 100.0 8 | Total 100.0 n/a n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/special_blocks 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 1 my $x; 34 | 14 35 | 15 BEGIN { 36 | 16 $x++ 37 | 17 } 38 | 18 39 | 19 CHECK { 40 | 20 $x++ 41 | 21 } 42 | 22 43 | 23 INIT { 44 | 24 $x++ 45 | 25 } 46 | 26 47 | 27 END { 48 | 28 $x++ 49 | 29 } 50 | 30 51 | 31 1 $x++; 52 | 53 | 54 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Util.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Util; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Cwd "abs_path"; 16 | use File::Spec; 17 | use base "Exporter"; 18 | 19 | our @EXPORT_OK = qw( remove_contained_paths ); 20 | 21 | sub remove_contained_paths { 22 | my ($container, @paths) = @_; 23 | 24 | # File::Spec's case tolerancy detection on *nix/Mac systems does not 25 | # take actual file system properties into account, but is better than 26 | # trying to normalize paths with per-os logic. On Windows it is 27 | # properly determined per drive. 28 | my ($drive) = File::Spec->splitpath($container); 29 | my $ignore_case = "(?i)"; 30 | $ignore_case = "" if !File::Spec->case_tolerant($drive); 31 | 32 | my $regex = qr[ 33 | $ignore_case # ignore case on tolerant filesystems 34 | ^ # string to match starts with: 35 | \Q$container\E # path, meta-quoted for safety 36 | ($|/) # followed by either the end of the string, or another 37 | # slash, to avoid removing paths in directories named 38 | # similar to the container 39 | ]x; 40 | 41 | @paths = grep { 42 | my $path = abs_path $_; # normalize backslashes 43 | $path !~ $regex; # check if path is inside the container 44 | } @paths; 45 | 46 | return @paths; 47 | } 48 | 49 | 1 50 | 51 | __END__ 52 | 53 | =head1 NAME 54 | 55 | Devel::Cover::Util - Utility subroutines for Devel::Cover 56 | 57 | =head1 SYNOPSIS 58 | 59 | use Devel::Cover::Util "remove_contained_paths"; 60 | 61 | =head1 DESCRIPTION 62 | 63 | This module utility subroutines for Devel::Cover. 64 | 65 | =head1 SUBROUTINES 66 | 67 | =head2 remove_contained_paths 68 | 69 | @Inc = remove_contained_paths(getcwd, @Inc); 70 | 71 | Remove certain paths from a list of paths. 72 | 73 | =head1 BUGS 74 | 75 | Huh? 76 | 77 | =head1 LICENCE 78 | 79 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 80 | 81 | This software is free. It is licensed under the same terms as Perl itself. 82 | 83 | The latest version of this software should be available from my homepage: 84 | http://www.pjcj.net 85 | 86 | =cut 87 | -------------------------------------------------------------------------------- /test_output/cover/cop.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/cop 91.6 n/a n/a 75.0 87.5 8 | Total 91.6 n/a n/a 75.0 87.5 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/cop 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 1 use lib "tests"; 38 | 1 39 | 1 40 | 14 41 | 15 *** 1 0 $SIG{__WARN__} = sub { die @_ }; 42 | *** 0 43 | 16 1 require COP; 44 | 45 | 46 | Covered Subroutines 47 | ------------------- 48 | 49 | Subroutine Count Location 50 | ---------- ----- ------------ 51 | BEGIN 1 tests/cop:10 52 | BEGIN 1 tests/cop:11 53 | BEGIN 1 tests/cop:13 54 | 55 | Uncovered Subroutines 56 | --------------------- 57 | 58 | Subroutine Count Location 59 | ---------- ----- ------------ 60 | __ANON__ 0 tests/cop:15 61 | 62 | 63 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Branch.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 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::Branch; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use base "Devel::Cover::Criterion"; 16 | 17 | sub pad { my $self = shift; $self->[0] = [0, 0] 18 | unless $self->[0] && @{$self->[0]}; } 19 | sub uncoverable { @_ > 1 ? $_[0][2][$_[1]] : scalar grep $_, @{$_[0][2]} } 20 | sub covered { @_ > 1 ? $_[0][0][$_[1]] : scalar grep $_, @{$_[0][0]} } 21 | sub total { scalar @{$_[0][0]} } 22 | sub value { $_[0][0][$_[1]] } 23 | sub values { @{$_[0][0]} } 24 | sub text { $_[0][1]{text} } 25 | sub criterion { 'branch' } 26 | 27 | 28 | sub percentage { 29 | my $t = $_[0]->total; 30 | sprintf "%3d", $t ? $_[0]->covered / $t * 100 : 0 31 | } 32 | 33 | sub error { 34 | my $self = shift; 35 | if (@_) { 36 | my $c = shift; 37 | return !($self->covered($c) xor $self->uncoverable($c)); 38 | } 39 | my $e = 0; 40 | for my $c (0 .. $#{$self->[0]}) { 41 | $e++ if !($self->covered($c) xor $self->uncoverable($c)); 42 | } 43 | $e 44 | } 45 | 46 | sub calculate_summary { 47 | my $self = shift; 48 | my ($db, $file) = @_; 49 | 50 | my $s = $db->{summary}; 51 | $self->pad; 52 | 53 | $self->aggregate($s, $file, "total", $self->total ); 54 | $self->aggregate($s, $file, "uncoverable", $self->uncoverable); 55 | $self->aggregate($s, $file, "covered", $self->covered ); 56 | $self->aggregate($s, $file, "error", $self->error ); 57 | } 58 | 59 | 1 60 | 61 | __END__ 62 | 63 | =head1 NAME 64 | 65 | Devel::Cover::Branch - Code coverage metrics for Perl 66 | 67 | =head1 SYNOPSIS 68 | 69 | use Devel::Cover::Branch; 70 | 71 | =head1 DESCRIPTION 72 | 73 | Module for storing branch coverage information. 74 | 75 | =head1 SEE ALSO 76 | 77 | Devel::Cover::Criterion 78 | 79 | =head1 METHODS 80 | 81 | =head1 BUGS 82 | 83 | Huh? 84 | 85 | =head1 LICENCE 86 | 87 | Copyright 2001-2014, Paul Johnson (paul@pjcj.net) 88 | 89 | This software is free. It is licensed under the same terms as Perl itself. 90 | 91 | The latest version of this software should be available from my homepage: 92 | http://www.pjcj.net 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /test_output/cover/bigint.5.008001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/bigint 100.0 50.0 n/a 100.0 93.7 8 | Total 100.0 50.0 n/a 100.0 93.7 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/bigint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2012-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 1 use Math::BigInt ":constant"; 38 | 1 39 | 1 40 | 14 41 | 15 1 my $x = 1; 42 | 16 *** 1 50 print $x if 1 >= $x; 43 | 44 | 45 | Branches 46 | -------- 47 | 48 | line err % true false branch 49 | ----- --- ------ ------ ------ ------ 50 | 16 *** 50 1 0 if {sign => '+', value => [1]} >= $x 51 | 52 | 53 | Covered Subroutines 54 | ------------------- 55 | 56 | Subroutine Count Location 57 | ---------- ----- --------------- 58 | BEGIN 1 tests/bigint:10 59 | BEGIN 1 tests/bigint:11 60 | BEGIN 1 tests/bigint:13 61 | 62 | 63 | -------------------------------------------------------------------------------- /test_output/cover/default_param.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/default_param 100.0 n/a 100.0 100.0 100.0 8 | Total 100.0 n/a 100.0 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/default_param 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 sub p { 34 | 14 2 100 2 my $x = shift || 11; 35 | 15 2 100 my $y = shift || []; 36 | 16 2 100 my $z = shift || {}; 37 | 17 } 38 | 18 39 | 19 1 p $_, $_, $_ for 0, 1; 40 | 1 41 | 2 42 | 43 | 44 | Conditions 45 | ---------- 46 | 47 | or 2 conditions 48 | 49 | line err % l !l expr 50 | ----- --- ------ ------ ------ ---- 51 | 14 100 1 1 shift @_ || 11 52 | 15 100 1 1 shift @_ || [] 53 | 16 100 1 1 shift @_ || {} 54 | 55 | 56 | Covered Subroutines 57 | ------------------- 58 | 59 | Subroutine Count Location 60 | ---------- ----- ---------------------- 61 | p 2 tests/default_param:14 62 | 63 | 64 | -------------------------------------------------------------------------------- /test_output/cover/fork.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/fork 100.0 75.0 n/a n/a 90.9 8 | Total 100.0 75.0 n/a n/a 90.9 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | Run: ... 19 | Perl version: ... 20 | OS: ... 21 | Start: ... 22 | Finish: ... 23 | 24 | tests/fork 25 | 26 | line err stmt bran cond sub code 27 | 1 #!/usr/bin/perl 28 | 2 29 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 30 | 4 31 | 5 # This software is free. It is licensed under the same terms as Perl itself. 32 | 6 33 | 7 # The latest version of this software should be available from my homepage: 34 | 8 # http://www.pjcj.net 35 | 9 36 | 10 # __COVER__ skip_test $^O eq "MSWin32" || $] == 5.008007 37 | 11 # __COVER__ skip_reason Fork unreliable 38 | 12 39 | 13 2 $x = 1; 40 | 14 41 | 15 *** 2 50 die unless defined ($pid = fork); 42 | 16 43 | 17 2 100 if ($pid) { 44 | 18 1 $x = 2; 45 | 19 1 waitpid $pid, 0; 46 | 20 } else { 47 | 21 1 $x = 3; 48 | 22 } 49 | 23 50 | 24 2 print "$x: $$\n"; 51 | 52 | 53 | Branches 54 | -------- 55 | 56 | line err % true false branch 57 | ----- --- ------ ------ ------ ------ 58 | 15 *** 50 0 2 unless defined($pid = fork) 59 | 17 100 1 1 if ($pid) { } 60 | 61 | 62 | -------------------------------------------------------------------------------- /test_output/cover/eval_nested.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/eval_nested 100.0 n/a 50.0 100.0 88.2 8 | Total 100.0 n/a 50.0 100.0 88.2 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/eval_nested 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 2 eval "eval q[ sub config { {} } ]"; 38 | 2 39 | 14 40 | 15 *** 1 50 my $e1 = config() || {}; 41 | 16 *** 1 50 my $e2 = config()->{mail} || {}; 42 | 43 | 44 | Conditions 45 | ---------- 46 | 47 | or 2 conditions 48 | 49 | line err % l !l expr 50 | ----- --- ------ ------ ------ ---- 51 | 15 *** 50 1 0 config() || {} 52 | 16 *** 50 0 1 config()->{'mail'} || {} 53 | 54 | 55 | Covered Subroutines 56 | ------------------- 57 | 58 | Subroutine Count Location 59 | ---------- ----- -------------------- 60 | BEGIN 1 tests/eval_nested:10 61 | BEGIN 1 tests/eval_nested:11 62 | config 2 tests/eval_nested:13 63 | 64 | 65 | -------------------------------------------------------------------------------- /test_output/cover/module_ignore.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/module_ignore 100.0 100.0 n/a n/a 100.0 8 | Total 100.0 100.0 n/a n/a 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/module_ignore 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 # __COVER__ ignore Module1 31 | 11 32 | 12 use strict; 33 | 13 use warnings; 34 | 14 35 | 15 use lib "tests"; 36 | 16 37 | 17 use Module1; 38 | 18 39 | 19 1 my @x; 40 | 20 41 | 21 1 for (0 .. 10) { 42 | 11 43 | 22 11 100 if (Module1::zz($_)) { 44 | 23 10 $x[0]++; 45 | 24 } else { 46 | 25 1 $x[1]++; 47 | 26 } 48 | 27 } 49 | 50 | 51 | Branches 52 | -------- 53 | 54 | line err % true false branch 55 | ----- --- ------ ------ ------ ------ 56 | 22 100 10 1 if (Module1::zz $_) { } 57 | 58 | 59 | -------------------------------------------------------------------------------- /test_output/cover/exec_die.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/exec_die 50.0 50.0 n/a 0.0 45.4 8 | Total 50.0 50.0 n/a 0.0 45.4 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/exec_die 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 # __COVER__ skip_test $^O eq "MSWin32" 31 | 11 # __COVER__ skip_reason Fork uses threads on Windows 32 | 12 33 | 13 *** 1 50 die unless defined ($pid = fork); 34 | 14 35 | 15 *** 1 50 if ($pid) { 36 | 16 1 wait; 37 | 17 } else { 38 | 18 *** 0 0 local *Devel::Cover::_report = sub { die "Badness happened!" }; 39 | *** 0 40 | 19 *** 0 exec "echo We want to be able to see this."; 41 | 20 } 42 | 43 | 44 | Branches 45 | -------- 46 | 47 | line err % true false branch 48 | ----- --- ------ ------ ------ ------ 49 | 13 *** 50 0 1 unless defined($pid = fork) 50 | 15 *** 50 1 0 if ($pid) { } 51 | 52 | 53 | Uncovered Subroutines 54 | --------------------- 55 | 56 | Subroutine Count Location 57 | ---------- ----- ----------------- 58 | __ANON__ 0 tests/exec_die:18 59 | 60 | 61 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Annotation/Random.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 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::Annotation::Random; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Getopt::Long; 16 | 17 | sub new { 18 | my $class = shift; 19 | bless {@_}, $class 20 | } 21 | 22 | sub get_options { 23 | my ($self, $opt) = @_; 24 | $self->{count} = 1; 25 | die "Bad option" unless 26 | GetOptions($self, 27 | qw( 28 | count=s 29 | )); 30 | } 31 | 32 | sub count { 33 | my $self = shift; 34 | $self->{count} 35 | } 36 | 37 | sub header { 38 | my $self = shift; 39 | my ($annotation) = @_; 40 | "rnd$annotation" 41 | } 42 | 43 | sub width { 44 | my $self = shift; 45 | my ($annotation) = @_; 46 | length $self->header($annotation) 47 | } 48 | 49 | sub text { 50 | my $self = shift; 51 | my ($file, $line, $annotation) = @_; 52 | return "" unless $line; 53 | $self->{annotation}{$file}[$line][$annotation] = int rand 10 54 | unless defined $self->{annotation}{$file}[$line][$annotation]; 55 | $self->{annotation}{$file}[$line][$annotation] 56 | } 57 | 58 | sub error { 59 | my $self = shift; 60 | my ($file, $line, $annotation) = @_; 61 | !$self->text($file, $line, $annotation) 62 | } 63 | 64 | sub class { 65 | my $self = shift; 66 | my ($file, $line, $annotation) = @_; 67 | return "" unless $line; 68 | "c" . int(($self->text($file, $line, $annotation) + 2) / 3) 69 | } 70 | 71 | 1 72 | 73 | __END__ 74 | 75 | =head1 NAME 76 | 77 | Devel::Cover::Annotation::Random - Example annotation for formatters 78 | 79 | =head1 SYNOPSIS 80 | 81 | cover -report text -annotation random -count 3 # Or any other report type 82 | 83 | =head1 DESCRIPTION 84 | 85 | This module provides an example annotation. 86 | It is designed to be called from the C program. 87 | 88 | =head1 SEE ALSO 89 | 90 | Devel::Cover 91 | 92 | =head1 BUGS 93 | 94 | Huh? 95 | 96 | =head1 LICENCE 97 | 98 | Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 99 | 100 | This software is free. It is licensed under the same terms as Perl itself. 101 | 102 | The latest version of this software should be available from my homepage: 103 | http://www.pjcj.net 104 | 105 | =cut 106 | -------------------------------------------------------------------------------- /test_output/cover/overload_bool.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/overload_bool 42.8 50.0 n/a 0.0 33.3 8 | Total 42.8 50.0 n/a 0.0 33.3 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/overload_bool 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 package Foo; 31 | 11 use overload 32 | 12 *** 0 0 '""' => sub { shift->render}, 33 | 13 *** 0 0 bool => sub { die; 1 }; 34 | *** 0 35 | 14 36 | 15 sub render { 37 | 16 *** 0 0 "foo"; 38 | 17 } 39 | 18 40 | 19 1 my $foo = 1; 41 | 20 *** 1 50 bless {}, 'Foo' if $foo; 42 | 21 43 | 22 1 1; 44 | 45 | 46 | Branches 47 | -------- 48 | 49 | line err % true false branch 50 | ----- --- ------ ------ ------ ------ 51 | 20 *** 50 1 0 if $foo 52 | 53 | 54 | Uncovered Subroutines 55 | --------------------- 56 | 57 | Subroutine Count Location 58 | ---------- ----- ---------------------- 59 | __ANON__ 0 tests/overload_bool:12 60 | __ANON__ 0 tests/overload_bool:13 61 | render 0 tests/overload_bool:16 62 | 63 | 64 | -------------------------------------------------------------------------------- /test_output/cover/subs_only.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/subs_only 100.0 n/a n/a 100.0 100.0 8 | Total 100.0 n/a n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/subs_only 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2006-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 # __COVER__ test_parameters -subs_only,1 31 | 11 32 | 12 use strict; 33 | 13 use warnings; 34 | 14 35 | 15 use lib "tests"; 36 | 16 37 | 17 my @x; 38 | 18 39 | 19 sub xx { 40 | 20 11 11 $x[shift]++; 41 | 21 } 42 | 22 43 | 23 for (0 .. 10) { 44 | 24 if (time) { 45 | 25 xx(0); 46 | 26 } else { 47 | 27 $x[1]++; 48 | 28 } 49 | 29 } 50 | 51 | 52 | Covered Subroutines 53 | ------------------- 54 | 55 | Subroutine Count Location 56 | ---------- ----- ------------------ 57 | xx 11 tests/subs_only:20 58 | 59 | 60 | -------------------------------------------------------------------------------- /test_output/cover/deparse.5.008: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/deparse 91.6 n/a n/a 75.0 87.5 8 | Total 91.6 n/a n/a 75.0 87.5 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/deparse 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl -l 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 1 1 use B::Deparse; 38 | 1 39 | 1 40 | 14 41 | 15 my $xx = sub { 42 | 16 *** 0 0 print "xx"; 43 | 17 1 }; 44 | 18 45 | 19 1 print B::Deparse->new->coderef2text($xx) 46 | 47 | 48 | Covered Subroutines 49 | ------------------- 50 | 51 | Subroutine Count Location 52 | ---------- ----- ---------------- 53 | BEGIN 1 tests/deparse:10 54 | BEGIN 1 tests/deparse:11 55 | BEGIN 1 tests/deparse:13 56 | 57 | Uncovered Subroutines 58 | --------------------- 59 | 60 | Subroutine Count Location 61 | ---------- ----- ---------------- 62 | __ANON__ 0 tests/deparse:16 63 | 64 | 65 | -------------------------------------------------------------------------------- /test_output/cover/alias.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/alias 100.0 100.0 n/a 100.0 100.0 8 | Total 100.0 100.0 n/a 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/alias 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 package Foo; 31 | 11 32 | 12 sub is_3digits { 33 | 13 2 2 my $val = shift; 34 | 14 2 my $retval = undef; 35 | 15 2 100 $retval=1 if $val =~ /^\d{3}$/; 36 | 16 2 return $retval; 37 | 17 } 38 | 18 39 | 19 package main; 40 | 20 41 | 21 1 *main::is_3digits = *Foo::is_3digits; 42 | 22 # delete $Foo::{is_3digits}; 43 | 23 44 | 24 1 is_3digits(1234); 45 | 25 1 is_3digits(123); 46 | 47 | 48 | Branches 49 | -------- 50 | 51 | line err % true false branch 52 | ----- --- ------ ------ ------ ------ 53 | 15 100 1 1 if $val =~ /^\d{3}$/ 54 | 55 | 56 | Covered Subroutines 57 | ------------------- 58 | 59 | Subroutine Count Location 60 | ---------- ----- -------------- 61 | is_3digits 2 tests/alias:13 62 | 63 | 64 | -------------------------------------------------------------------------------- /test_output/cover/default_param.5.014000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/default_param 100.0 n/a 100.0 100.0 100.0 8 | Total 100.0 n/a 100.0 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/default_param 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 sub p { 38 | 14 2 100 2 my $x = shift || 11; 39 | 15 2 100 my $y = shift || []; 40 | 16 2 100 my $z = shift || {}; 41 | 17 } 42 | 18 43 | 19 1 p $_, $_, $_ for 0, 1; 44 | 45 | 46 | Conditions 47 | ---------- 48 | 49 | or 2 conditions 50 | 51 | line err % l !l expr 52 | ----- --- ------ ------ ------ ---- 53 | 14 100 1 1 shift() || 11 54 | 15 100 1 1 shift() || [] 55 | 16 100 1 1 shift() || {} 56 | 57 | 58 | Covered Subroutines 59 | ------------------- 60 | 61 | Subroutine Count Location 62 | ---------- ----- ---------------------- 63 | BEGIN 1 tests/default_param:10 64 | BEGIN 1 tests/default_param:11 65 | p 2 tests/default_param:14 66 | 67 | 68 | -------------------------------------------------------------------------------- /test_output/cover/cond_xor.5.006001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/cond_xor 100.0 n/a 66.6 n/a 82.6 8 | Total 100.0 n/a 66.6 n/a 82.6 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/cond_xor 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2002-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 use strict; 31 | 11 use warnings; 32 | 12 33 | 13 1 my $i = 1; 34 | 14 1 my $j = 0; 35 | 15 36 | 16 1 for my $y (0, 1, 1, 1) { 37 | 4 38 | 17 4 for my $z (0, 0, 1) { 39 | 12 40 | 18 12 my $x = $y ^ $z; 41 | 19 12 100 $x = ($y xor $z); 42 | 20 43 | 21 *** 12 50 my $p = ($i xor $y); 44 | 22 *** 12 50 $p = ($j xor $y); 45 | 23 12 $p ^= $y; 46 | 24 } 47 | 25 } 48 | 49 | 50 | Conditions 51 | ---------- 52 | 53 | xor 4 conditions 54 | 55 | line err % l&&r l&&!r !l&&r !l&&!r expr 56 | ----- --- ------ ------ ------ ------ ------ ---- 57 | 19 100 3 6 1 2 $y xor $z 58 | 21 *** 50 9 3 0 0 $i xor $y 59 | 22 *** 50 0 0 9 3 $j xor $y 60 | 61 | 62 | -------------------------------------------------------------------------------- /test_output/cover/default_param.5.008001: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------------------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------------------------------ ------ ------ ------ ------ ------ 7 | tests/default_param 100.0 n/a 100.0 100.0 100.0 8 | Total 100.0 n/a 100.0 100.0 100.0 9 | ------------------------------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/default_param 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2004-2014, Paul Johnson (paul@pjcj.net) 24 | 4 25 | 5 # This software is free. It is licensed under the same terms as Perl itself. 26 | 6 27 | 7 # The latest version of this software should be available from my homepage: 28 | 8 # http://www.pjcj.net 29 | 9 30 | 10 1 1 use strict; 31 | 1 32 | 1 33 | 11 1 1 use warnings; 34 | 1 35 | 1 36 | 12 37 | 13 sub p { 38 | 14 2 100 2 my $x = shift || 11; 39 | 15 2 100 my $y = shift || []; 40 | 16 2 100 my $z = shift || {}; 41 | 17 } 42 | 18 43 | 19 1 p $_, $_, $_ for 0, 1; 44 | 1 45 | 46 | 47 | Conditions 48 | ---------- 49 | 50 | or 2 conditions 51 | 52 | line err % l !l expr 53 | ----- --- ------ ------ ------ ---- 54 | 14 100 1 1 shift @_ || 11 55 | 15 100 1 1 shift @_ || [] 56 | 16 100 1 1 shift @_ || {} 57 | 58 | 59 | Covered Subroutines 60 | ------------------- 61 | 62 | Subroutine Count Location 63 | ---------- ----- ---------------------- 64 | BEGIN 1 tests/default_param:10 65 | BEGIN 1 tests/default_param:11 66 | p 2 tests/default_param:14 67 | 68 | 69 | --------------------------------------------------------------------------------