├── .autoenv.zsh ├── .codespell ├── .dprint.json ├── .editorconfig ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .hadolint.yaml ├── .markdownlint.yaml ├── .mdformat.toml ├── .perlcriticrc ├── .perlimports.toml ├── .perltidyrc ├── .shellcheckrc ├── .typos.toml ├── .yamllint ├── Changes ├── Contributors ├── Cover.xs ├── MANIFEST.SKIP ├── Makefile.PL ├── README.md ├── bin ├── cover ├── cpancover ├── gcov2perl └── queue ├── dist.ini ├── docker ├── BUILD ├── README.md ├── cpancover │ └── Dockerfile ├── devel-cover-base │ └── Dockerfile ├── devel-cover-git │ └── Dockerfile ├── devel-cover-local │ └── Dockerfile └── perl-5.40.2 │ └── Dockerfile ├── docs ├── BUGS ├── CONTRIBUTING.md ├── RELEASE.md ├── TODO ├── cpancover.md └── memorium.md ├── lib └── Devel │ ├── Cover.pm │ └── Cover │ ├── Annotation │ ├── Git.pm │ ├── Random.pm │ └── Svk.pm │ ├── Branch.pm │ ├── Collection.pm │ ├── Condition.pm │ ├── Condition_and_2.pm │ ├── Condition_and_3.pm │ ├── Condition_or_2.pm │ ├── Condition_or_3.pm │ ├── Condition_xor_4.pm │ ├── Criterion.pm │ ├── DB.pm │ ├── DB │ ├── Digests.pm │ ├── File.pm │ ├── IO.pm │ ├── IO │ │ ├── Base.pm │ │ ├── JSON.pm │ │ ├── Sereal.pm │ │ └── Storable.pm │ └── Structure.pm │ ├── Dumper.pm │ ├── Html_Common.pm │ ├── Op.pm │ ├── Pod.pm │ ├── Report │ ├── Compilation.pm │ ├── Html.pm │ ├── Html_basic.pm │ ├── Html_minimal.pm │ ├── Html_subtle.pm │ ├── Json.pm │ ├── Sort.pm │ ├── Text.pm │ ├── Text2.pm │ └── Vim.pm │ ├── Statement.pm │ ├── Subroutine.pm │ ├── Test.pm │ ├── Time.pm │ ├── Truth_Table.pm │ ├── Tutorial.pod │ ├── Util.pm │ └── Web.pm ├── t ├── 00-report-prereqs.t ├── internal │ ├── criteria.t │ ├── inc_filter.t │ ├── inc_filter │ │ ├── cwd │ │ │ └── lib │ │ │ │ └── .dummy │ │ └── cwd_lib │ │ │ └── .dummy │ ├── launch.t │ └── subprocess.t └── regexp │ └── regexp_eval.t ├── test_output └── cover │ ├── accessor.5.012000 │ ├── alias.5.012000 │ ├── alias1.5.012000 │ ├── and.5.012000 │ ├── any_all.5.041010 │ ├── bigint.5.032000 │ ├── branch_return_sub.5.012000 │ ├── change.5.012000 │ ├── circular_ref.5.012000 │ ├── cond_and.5.012000 │ ├── cond_branch.5.012000 │ ├── cond_branch.5.014000 │ ├── cond_branch.5.016000 │ ├── cond_branch.5.018000 │ ├── cond_chained.5.012000 │ ├── cond_chained.5.016000 │ ├── cond_or.5.012000 │ ├── cond_or.5.022000 │ ├── cond_or.5.038000 │ ├── cond_xor.5.012000 │ ├── cond_xor.5.041002 │ ├── cond_xor_hp.5.040000 │ ├── cond_xor_hp.5.041002 │ ├── cop.5.012000 │ ├── dbm_cond.5.014000 │ ├── dbm_cond.5.022000 │ ├── default_param.5.012000 │ ├── default_param.5.014000 │ ├── deparse.5.012000 │ ├── destroy.5.012000 │ ├── dynamic_subs.5.012000 │ ├── empty.5.012000 │ ├── end_constant.5.012000 │ ├── eval1.5.012000 │ ├── eval2.5.012000 │ ├── eval3.5.012000 │ ├── eval_merge.5.012000 │ ├── eval_merge.t.5.012000 │ ├── eval_merge_0.5.012000 │ ├── eval_merge_1.5.012000 │ ├── eval_merge_sep.t.5.012000 │ ├── eval_nested.5.012000 │ ├── eval_string.5.012000 │ ├── eval_sub.t.5.012000 │ ├── eval_use.t.5.012000 │ ├── exec.5.012000 │ ├── exec_die.5.012000 │ ├── final_op.5.012000 │ ├── fork.5.012000 │ ├── if.5.012000 │ ├── md5.5.012000 │ ├── module1.5.012000 │ ├── module2.5.012000 │ ├── module_ignore.5.012000 │ ├── module_import.5.012000 │ ├── module_relative.5.012000 │ ├── module_statements.5.012000 │ ├── moo_cond.5.012000 │ ├── moo_cond.5.022000 │ ├── moose_basic.5.012000 │ ├── moose_cond.5.012000 │ ├── moose_constraint.5.012000 │ ├── moose_constraint.5.016000 │ ├── overload_bool.5.012000 │ ├── overload_bool2.5.012000 │ ├── overload_bool2.5.022000 │ ├── overload_bool2.5.038000 │ ├── overloaded.5.012000 │ ├── padrange.5.012000 │ ├── padrange2.5.012000 │ ├── padrange2.5.018000 │ ├── padrange2.5.022000 │ ├── pod.5.012000 │ ├── pod_nocp.5.012000 │ ├── readonly.5.012000 │ ├── recursive_sub.5.016000 │ ├── redefine_sub.5.012000 │ ├── require.5.012000 │ ├── signature.5.032000 │ ├── skip.5.012000 │ ├── sort.5.012000 │ ├── special_blocks.5.012000 │ ├── statement.5.012000 │ ├── subs_only.5.012000 │ ├── t0.5.012000 │ ├── t1.5.012000 │ ├── t2.5.012000 │ ├── taint.5.012000 │ ├── trivial.5.012000 │ ├── uncoverable.5.012000 │ ├── uncoverable_error.5.012000 │ ├── uncoverable_error_ignore.5.012000 │ └── xor_constant_fold.5.012000 ├── tests ├── .uncoverable ├── Accessor_maker.pm ├── Alias1.pm ├── COP.pm ├── E2.pm ├── E3.pm ├── E4.pm ├── IncSub.pm ├── Module1.pm ├── Module2.pm ├── Module_import.pm ├── PodMod.pm ├── Taint.pm ├── accessor ├── alias ├── alias1 ├── and ├── any_all ├── bigint ├── branch_return_sub ├── change.t ├── circular_ref ├── cond_and ├── cond_branch ├── cond_chained ├── cond_or ├── cond_or.pl ├── cond_xor ├── cond_xor_hp ├── cop ├── dbm_cond ├── default_param ├── deparse ├── destroy ├── dist │ └── DC-Test-Dist │ │ ├── Makefile.PL │ │ ├── lib │ │ └── DC │ │ │ └── Test │ │ │ ├── Dist.pm │ │ │ └── Dist │ │ │ └── M1.pm │ │ └── t │ │ └── t1.t ├── dynamic_subs ├── empty ├── end_constant ├── eval1 ├── eval2 ├── eval3 ├── eval_merge ├── eval_merge.t ├── eval_merge_0 ├── eval_merge_1 ├── eval_merge_sep.t ├── eval_nested ├── eval_string ├── eval_sub.t ├── eval_use.t ├── exec ├── exec_die ├── final_op ├── fork ├── if ├── inc_sub ├── md5.t ├── module1 ├── module2 ├── module_ignore ├── module_import ├── module_relative ├── module_statements ├── moo_cond ├── moose_basic ├── moose_cond ├── moose_constraint ├── overload_bool ├── overload_bool2 ├── overloaded ├── padrange ├── padrange2 ├── pod ├── pod_nocp ├── random │ └── dir │ │ └── file ├── readonly ├── recursive_sub ├── redefine_sub ├── require ├── signature ├── skip ├── sort ├── special_blocks ├── statement ├── subs_only ├── t0 ├── t1 ├── t2 ├── taint ├── trivial ├── uncoverable ├── uncoverable_error ├── uncoverable_error_ignore └── xor_constant_fold └── utils ├── Devel └── Cover │ └── BuildUtils.pm ├── all_versions ├── bisect.sh ├── cpancover.nginx ├── create_all_gold ├── create_gold ├── dc ├── mail_contributors ├── makeh ├── queue.conf ├── scanuncov ├── setup └── typemap /.autoenv.zsh: -------------------------------------------------------------------------------- 1 | if [[ $autoenv_event == "enter" ]]; then 2 | . ./utils/setup 3 | else 4 | fi 5 | -------------------------------------------------------------------------------- /.codespell: -------------------------------------------------------------------------------- 1 | Aas 2 | -------------------------------------------------------------------------------- /.dprint.json: -------------------------------------------------------------------------------- 1 | { 2 | "lineWidth": 80, 3 | "newLineKind": "lf", 4 | "typescript": {}, 5 | "json": {}, 6 | "markdown": {}, 7 | "toml": {}, 8 | "dockerfile": {}, 9 | "excludes": [ 10 | "**/node_modules", 11 | "**/*-lock.json" 12 | ], 13 | "plugins": [ 14 | "https://plugins.dprint.dev/typescript-0.91.1.wasm", 15 | "https://plugins.dprint.dev/json-0.19.3.wasm", 16 | "https://plugins.dprint.dev/markdown-0.17.1.wasm", 17 | "https://plugins.dprint.dev/toml-0.6.2.wasm", 18 | "https://plugins.dprint.dev/dockerfile-0.3.2.wasm" 19 | ] 20 | } 21 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | charset = utf-8 5 | end_of_line = lf 6 | indent_style = space 7 | indent_size = 2 8 | tab_width = 2 9 | insert_final_newline = true 10 | max_line_length = 80 11 | trim_trailing_whitespace = true 12 | 13 | [Makefile] 14 | indent_style = tab 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.org 2 | *.bak 3 | *.sw? 4 | *~ 5 | ._* 6 | .DS_Store 7 | tmp/ 8 | 9 | tags* 10 | .perl-version 11 | Cover.bs 12 | Cover.c 13 | Cover.o 14 | Makefile 15 | Makefile.old 16 | blib/ 17 | .build/ 18 | README 19 | cover_db*/ 20 | t/e2e/ 21 | lib/Devel/Cover/Inc.pm 22 | pm_to_blib 23 | *.out 24 | *.tar.bz2 25 | *.tar.gz 26 | *.patch 27 | *.orig 28 | *.rej 29 | MYMETA.* 30 | Cover.def 31 | dll.base 32 | dll.exp 33 | Devel-Cover-* 34 | !*/Devel-Cover-* 35 | callgrind.out.* 36 | staging/ 37 | queue.db 38 | -------------------------------------------------------------------------------- /.hadolint.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | failure-threshold: style 3 | -------------------------------------------------------------------------------- /.markdownlint.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | default: true 3 | MD013: { stern: true } 4 | MD024: { siblings_only: true } 5 | -------------------------------------------------------------------------------- /.mdformat.toml: -------------------------------------------------------------------------------- 1 | number = true 2 | -------------------------------------------------------------------------------- /.perlimports.toml: -------------------------------------------------------------------------------- 1 | # Valid log levels are: 2 | # debug, info, notice, warning, error, critical, alert, emergency 3 | # critical, alert and emergency are not currently used. 4 | # 5 | # Please use boolean values in this config file. Negated options (--no-*) are 6 | # not permitted here. Explicitly set options to true or false. 7 | # 8 | # Some of these values deviate from the regular perlimports defaults. In 9 | # particular, you're encouraged to leave preserve_duplicates and 10 | # preserve_unused disabled. 11 | 12 | cache = false # setting this to true is discouraged 13 | ignore_modules = ["namespace::clean", "Class::XSAccessor", "DynaLoader"] 14 | ignore_modules_filename = "" 15 | ignore_modules_pattern = "" # regex like "^(Foo|Foo::Bar)" 16 | ignore_modules_pattern_filename = "" 17 | libs = ["lib", "t/lib"] 18 | log_filename = "" 19 | log_level = "warn" 20 | never_export_modules = [] 21 | never_export_modules_filename = "" 22 | padding = true 23 | preserve_duplicates = false 24 | preserve_unused = false 25 | tidy_whitespace = true 26 | -------------------------------------------------------------------------------- /.shellcheckrc: -------------------------------------------------------------------------------- 1 | shell=bash 2 | external-sources=true 3 | enable=add-default-case 4 | enable=avoid-nullary-conditions 5 | enable=check-unassigned-uppercase 6 | enable=deprecate-which 7 | enable=require-double-brackets 8 | -------------------------------------------------------------------------------- /.typos.toml: -------------------------------------------------------------------------------- 1 | [files] 2 | extend-exclude = [ ".codespell" ] 3 | ignore-hidden = false 4 | 5 | [default.extend-words] 6 | thr = "thr" 7 | 8 | [default.extend-identifiers] 9 | 10 | [default] 11 | 12 | extend-ignore-words-re = [ 13 | ] 14 | 15 | extend-ignore-identifiers-re = [ 16 | ] 17 | 18 | extend-ignore-re = [ 19 | '"[^"]+"\n\n__END__\n\n', # quotes 20 | '::ProhibitMultipleWiths\b', # perl critic 21 | 'Gisle Aas', # author 22 | ] 23 | -------------------------------------------------------------------------------- /.yamllint: -------------------------------------------------------------------------------- 1 | --- 2 | extends: default 3 | 4 | rules: 5 | braces: { min-spaces-inside: 1, max-spaces-inside: 1 } 6 | brackets: { min-spaces-inside: 1, max-spaces-inside: 1 } 7 | comments: 8 | level: error 9 | comments-indentation: disable 10 | document-start: 11 | level: error 12 | truthy: 13 | level: error 14 | -------------------------------------------------------------------------------- /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 | .perl-version 30 | \.db 31 | ^\.build\b 32 | -------------------------------------------------------------------------------- /docker/README.md: -------------------------------------------------------------------------------- 1 | # Devel::Cover Docker 2 | 3 | This repository contains Dockerfiles and a script to create the docker images 4 | for [cpancover](http://cpancover.com). 5 | 6 | To build the latest image, run `./BUILD` 7 | 8 | If you don't have permissions to push the image as user `pjcj` then use the 9 | `--user` option to `BUILD` to specify a user for whom you do have permissions. 10 | 11 | This command will build a docker image for running a Devel::Cover run on a 12 | module, and this will be used in cpancover.com. 13 | 14 | On the cpancover server, check out the version of Devel::Cover you want to use 15 | and then follow the instructions in 16 | [docs/cpancover.md](https://github.com/pjcj/Devel--Cover/blob/main/docs/cpancover.md). 17 | -------------------------------------------------------------------------------- /docker/cpancover/Dockerfile: -------------------------------------------------------------------------------- 1 | # hadolint ignore=DL3007 2 | FROM pjcj/devel-cover-dc:latest 3 | RUN perl Makefile.PL && make t && make install && make clean && \ 4 | echo 6 > version.txt 5 | ENV PATH=/dc/utils:$PATH 6 | -------------------------------------------------------------------------------- /docker/devel-cover-base/Dockerfile: -------------------------------------------------------------------------------- 1 | # hadolint ignore=DL3007 2 | FROM pjcj/perl-5.40.2:latest 3 | 4 | WORKDIR /usr/local/src 5 | 6 | # # Add Docker's official GPG key: 7 | # sudo apt-get update 8 | # sudo apt-get install ca-certificates curl 9 | # sudo install -m 0755 -d /etc/apt/keyrings 10 | # sudo curl -fsSL https://download.docker.com/linux/ubuntu/gpg -o /etc/apt/keyrings/docker.asc 11 | # sudo chmod a+r /etc/apt/keyrings/docker.asc 12 | 13 | # # Add the repository to Apt sources: 14 | # echo \ 15 | # "deb [arch=$(dpkg --print-architecture) signed-by=/etc/apt/keyrings/docker.asc] https://download.docker.com/linux/ubuntu \ 16 | # $(. /etc/os-release && echo "$VERSION_CODENAME") stable" | \ 17 | # sudo tee /etc/apt/sources.list.d/docker.list > /dev/null 18 | # sudo apt-get update 19 | 20 | # hadolint ignore=DL3008 21 | RUN \ 22 | apt-get update && \ 23 | apt-get -y --no-install-recommends install git libssl-dev libz-dev \ 24 | ca-certificates curl pigz && \ 25 | update-ca-certificates && \ 26 | install -m 0755 -d /etc/apt/keyrings && \ 27 | curl -fsSL https://download.docker.com/linux/ubuntu/gpg -o \ 28 | /etc/apt/keyrings/docker.asc && \ 29 | chmod a+r /etc/apt/keyrings/docker.asc && \ 30 | echo "deb [arch=$(dpkg --print-architecture) signed-by=/etc/apt/keyrings/docker.asc] https://download.docker.com/linux/ubuntu $(. /etc/os-release && echo "$VERSION_CODENAME") stable" > /etc/apt/sources.list.d/docker.list && \ 31 | apt-get update && \ 32 | apt-get -y --no-install-recommends install docker-ce docker-ce-cli \ 33 | containerd.io docker-buildx-plugin docker-compose-plugin && \ 34 | rm -rf /var/lib/apt/lists/* 35 | 36 | RUN \ 37 | cpan -Ti \ 38 | B::Debug \ 39 | CGI \ 40 | CPAN::DistnameInfo \ 41 | CPAN::Releases::Latest \ 42 | Capture::Tiny \ 43 | Class::XSAccessor \ 44 | Digest::MD5 \ 45 | JSON::MaybeXS \ 46 | Moo \ 47 | Parallel::Iterator \ 48 | Pod::Coverage::CountParents \ 49 | Sereal \ 50 | Template \ 51 | Template \ 52 | namespace::clean \ 53 | && rm -rf ~/.cpan/build ~/.cpan/sources/authors ~/.cpanm \ 54 | ~/.local/share/.cpan/build ~/.local/share/.cpan/sources/authors 55 | -------------------------------------------------------------------------------- /docker/devel-cover-git/Dockerfile: -------------------------------------------------------------------------------- 1 | # hadolint ignore=DL3007 2 | FROM pjcj/devel-cover-base:latest 3 | ARG BRANCH=main 4 | ARG REPO=https://github.com/pjcj/Devel--Cover 5 | WORKDIR /dc 6 | RUN git clone "$REPO" /dc --depth 1 -b "$BRANCH" 7 | -------------------------------------------------------------------------------- /docker/devel-cover-local/Dockerfile: -------------------------------------------------------------------------------- 1 | # hadolint ignore=DL3007 2 | FROM pjcj/devel-cover-base:latest 3 | WORKDIR /dc 4 | COPY src /dc 5 | -------------------------------------------------------------------------------- /docker/perl-5.40.2/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:24.04 2 | 3 | ENV TERM=xterm 4 | SHELL ["/bin/bash", "-o", "pipefail", "-c"] 5 | 6 | # hadolint ignore=DL3008 7 | RUN apt-get update && apt-get -y --no-install-recommends install wget build-essential && rm -rf /var/lib/apt/lists/* 8 | 9 | RUN wget --progress=dot:giga http://www.cpan.org/src/5.0/perl-5.40.2.tar.gz -O - | tar xzvf - -C /usr/local/src 10 | WORKDIR /usr/local/src/perl-5.40.2 11 | RUN ./Configure -des && make install 12 | WORKDIR / 13 | RUN rm -rf /usr/local/src/perl-5.40.2 14 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /docs/RELEASE.md: -------------------------------------------------------------------------------- 1 | # Devel::Cover Release Process 2 | 3 | 1. Update Changes 4 | - Add important changes 5 | - Credit the author as appropriate 6 | - Include github and RT numbers 7 | 8 | 2. Check it in 9 | - `git commit -m "Add Changes" Changes` 10 | 11 | 3. Update Contributors 12 | 13 | 4. Check it in 14 | - `git commit -m "Update Contributors" Contributors` 15 | 16 | 5. Update `$Latest_t` in `Makefile.PL` 17 | - Update test for obsolete development version skipping via 18 | `$LATEST_RELEASED_PERL` variable in Devel::Cover::Test.pm 19 | - Update version number in `Makefile.PL` 20 | 21 | 6. Check it in 22 | - `git commit -am "Bump version number"` 23 | 24 | 7. Run basic tests 25 | - `perl Makefile.PL && make` 26 | - `make test` 27 | 28 | 8. Test against all versions 29 | - `make all_test` 30 | 31 | 9. Return to base perl version 32 | - `perl Makefile.PL && make` 33 | 34 | 10. If there's a new stable release of perl: 35 | - `dc install_dzil` 36 | 37 | 11. Make the release 38 | - `dzil release` 39 | -------------------------------------------------------------------------------- /docs/memorium.md: -------------------------------------------------------------------------------- 1 | # In Memorium 2 | 3 | ## 1.45 4 | 5 | Version 1.45 is dedicated to the memory of Abe Timmerman (abeltje). 6 | 7 | A lot of Devel::Cover work in recent years has been completed at Perl QA 8 | Hackathons and Perl Toolchain Summits. Very often at these events I would sit 9 | next to Abe as he was working on Perl's test smoking infrastructure. 10 | 11 | Frequently Abe would be deep into a problem with his headphones on. And then 12 | occasionally he would lean back in his chair and play a little drum roll. Then 13 | he might take off his headphones and we'd discuss what we were working on or 14 | maybe some other topic. 15 | 16 | Thanks for those good times, Abe. This release is dedicated to you. 17 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Annotation/Random.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2025, 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 | # https://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 GetOptions( 26 | $self, qw( 27 | count=s 28 | ) 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-2025, 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 | https://pjcj.net 104 | 105 | =cut 106 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Branch.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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 { 18 | my $self = shift; 19 | $self->[0] = [ 0, 0 ] unless $self->[0] && @{ $self->[0] }; 20 | } 21 | sub uncoverable { @_ > 1 ? $_[0][2][ $_[1] ] : scalar grep $_, @{ $_[0][2] } } 22 | sub covered { @_ > 1 ? $_[0][0][ $_[1] ] : scalar grep $_, @{ $_[0][0] } } 23 | sub total { scalar @{ $_[0][0] } } 24 | sub value { $_[0][0][ $_[1] ] } 25 | sub values { @{ $_[0][0] } } 26 | sub text { $_[0][1]{text} } 27 | sub criterion { "branch" } 28 | 29 | sub percentage { 30 | my $t = $_[0]->total; 31 | sprintf "%3d", $t ? $_[0]->covered / $t * 100 : 0 32 | } 33 | 34 | sub error { 35 | my $self = shift; 36 | if (@_) { 37 | my $c = shift; 38 | return $self->err_chk($self->covered($c), $self->uncoverable($c)); 39 | } 40 | my $e = 0; 41 | for my $c (0 .. $#{ $self->[0] }) { 42 | $e++ if $self->err_chk($self->covered($c), $self->uncoverable($c)); 43 | } 44 | $e 45 | } 46 | 47 | sub calculate_summary { 48 | my $self = shift; 49 | my ($db, $file) = @_; 50 | 51 | my $s = $db->{summary}; 52 | $self->pad; 53 | 54 | $self->aggregate($s, $file, "total", $self->total); 55 | $self->aggregate($s, $file, "uncoverable", $self->uncoverable); 56 | $self->aggregate($s, $file, "covered", $self->covered); 57 | $self->aggregate($s, $file, "error", $self->error); 58 | } 59 | 60 | 1 61 | 62 | __END__ 63 | 64 | =head1 NAME 65 | 66 | Devel::Cover::Branch - Code coverage metrics for Perl 67 | 68 | =head1 SYNOPSIS 69 | 70 | use Devel::Cover::Branch; 71 | 72 | =head1 DESCRIPTION 73 | 74 | Module for storing branch coverage information. 75 | 76 | =head1 SEE ALSO 77 | 78 | Devel::Cover::Criterion 79 | 80 | =head1 METHODS 81 | 82 | =head1 BUGS 83 | 84 | Huh? 85 | 86 | =head1 LICENCE 87 | 88 | Copyright 2001-2025, Paul Johnson (paul@pjcj.net) 89 | 90 | This software is free. It is licensed under the same terms as Perl itself. 91 | 92 | The latest version of this software should be available from my homepage: 93 | https://pjcj.net 94 | 95 | =cut 96 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 58 | 59 | =cut 60 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_and_2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_and_3.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_or_2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_or_3.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 55 | 56 | =cut 57 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Condition_xor_4.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/File.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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 | for my $criterion ($self->items) { 41 | next unless exists $s->{$criterion}; 42 | my $c = "Devel::Cover::\u$criterion"; 43 | # print "$c\n"; 44 | $c->calculate_percentage($db, $s->{$criterion}); 45 | } 46 | Devel::Cover::Criterion->calculate_percentage($db, $s->{total}); 47 | # print STDERR Dumper $s; 48 | } 49 | 50 | 1 51 | 52 | __END__ 53 | 54 | =head1 NAME 55 | 56 | Devel::Cover::DB::File - Code coverage metrics for Perl 57 | 58 | =head1 SYNOPSIS 59 | 60 | use Devel::Cover::DB::File; 61 | 62 | =head1 DESCRIPTION 63 | 64 | =head1 SEE ALSO 65 | 66 | Devel::Cover 67 | 68 | =head1 METHODS 69 | 70 | =head1 BUGS 71 | 72 | Huh? 73 | 74 | =head1 LICENCE 75 | 76 | Copyright 2001-2025, 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 | https://pjcj.net 82 | 83 | =cut 84 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2011-2025, 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 | # https://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 { require JSON::MaybeXS; 1 }; 20 | $Format = "Storable" if !$Format and eval "use Storable; 1"; 21 | die "Can't load either JSON or Storable" unless $Format; 22 | } 23 | 24 | sub new { 25 | my $class = shift; 26 | 27 | my $format = $ENV{DEVEL_COVER_DB_FORMAT} || $Format; 28 | ($format) = $format =~ /(.*)/; # die tainting 29 | die "Devel::Cover: Unrecognised DB format: $format" 30 | unless $format =~ /^(?:Storable|JSON|Sereal)$/; 31 | 32 | $class .= "::$format"; 33 | eval "use $class; 1" or die "Devel::Cover: $@"; 34 | 35 | $class->new(options => $ENV{DEVEL_COVER_IO_OPTIONS} || "", @_) 36 | } 37 | 38 | 1 39 | 40 | __END__ 41 | 42 | =head1 NAME 43 | 44 | Devel::Cover::DB::IO - IO routines for Devel::Cover::DB 45 | 46 | =head1 SYNOPSIS 47 | 48 | use Devel::Cover::DB::IO; 49 | 50 | my $io = Devel::Cover::DB::IO->new(format => "JSON"); 51 | my $data = $io->read($file); 52 | $io->write($data, $file); 53 | 54 | =head1 DESCRIPTION 55 | 56 | This module provides IO routines for Devel::Cover::DB. 57 | 58 | =head1 SEE ALSO 59 | 60 | Devel::Cover 61 | 62 | =head1 METHODS 63 | 64 | =head2 new 65 | 66 | my $io = Devel::Cover::DB::IO->new(format => "JSON"); 67 | 68 | Constructs the IO object. 69 | 70 | =head2 read 71 | 72 | my $data = $io->read($file); 73 | 74 | Returns a perl data structure representing the data read from $file. 75 | 76 | =head2 write 77 | 78 | $io->write($data, $file); 79 | 80 | Writes $data to $file in the format specified when creating $io. 81 | 82 | =head1 BUGS 83 | 84 | Huh? 85 | 86 | =head1 LICENCE 87 | 88 | Copyright 2011-2025, Paul Johnson (paul@pjcj.net) 89 | 90 | This software is free. It is licensed under the same terms as Perl itself. 91 | 92 | The latest version of this software should be available from my homepage: 93 | https://pjcj.net 94 | 95 | =cut 96 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO/Base.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2017-2025, 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 | # https://pjcj.net 7 | 8 | package Devel::Cover::DB::IO::Base; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Fcntl ":flock"; 14 | 15 | # VERSION 16 | 17 | sub new { 18 | my $class = shift; 19 | bless {@_}, $class 20 | } 21 | 22 | sub _lock { 23 | my $self = shift; 24 | my ($file, $type) = @_; 25 | my $lock = "$file.lock"; 26 | open my $fh, "+>>", $lock or die "Can't open $lock: $!\n"; 27 | flock $fh, $type or die "Can't lock $lock: $!\n"; 28 | $fh 29 | } 30 | 31 | sub _read { 32 | my $self = shift; 33 | my ($file, $reader) = @_; 34 | my $lock_fh = $self->_lock($file, LOCK_SH); 35 | $reader->() 36 | } 37 | 38 | sub _write { 39 | my $self = shift; 40 | my ($file, $writer) = @_; 41 | my $lock_fh = $self->_lock($file, LOCK_EX); 42 | unlink $file; 43 | $writer->(); 44 | $self 45 | } 46 | 47 | sub _read_fh { 48 | my $self = shift; 49 | my ($file, $reader) = @_; 50 | $self->_read( 51 | $file, 52 | sub { 53 | open my $fh, "<", $file or die "Can't open $file: $!\n"; 54 | my $data = $reader->($fh); 55 | close $fh or die "Can't close $file: $!\n"; 56 | $data 57 | } 58 | ) 59 | } 60 | 61 | sub _write_fh { 62 | my $self = shift; 63 | my ($file, $writer) = @_; 64 | $self->_write( 65 | $file, 66 | sub { 67 | open my $fh, ">", $file or die "Can't open $file: $!\n"; 68 | $writer->($fh); 69 | close $fh or die "Can't close $file: $!\n"; 70 | } 71 | ) 72 | } 73 | 74 | " 75 | Green trees call to me 76 | I am free but life is so cheap 77 | " 78 | 79 | __END__ 80 | 81 | =head1 NAME 82 | 83 | Devel::Cover::DB::IO::Base - Base class for IO routines for Devel::Cover::DB 84 | 85 | =head1 SYNOPSIS 86 | 87 | use parent "Devel::Cover::DB::IO::Base"; 88 | 89 | =head1 DESCRIPTION 90 | 91 | This module is a base class for IO routines for Devel::Cover::DB. 92 | 93 | =head1 SEE ALSO 94 | 95 | L 96 | 97 | =head1 METHODS 98 | 99 | =head1 BUGS 100 | 101 | Huh? 102 | 103 | =head1 LICENCE 104 | 105 | Copyright 2017-2025, Paul Johnson (paul@pjcj.net) 106 | 107 | This software is free. It is licensed under the same terms as Perl itself. 108 | 109 | The latest version of this software should be available from my homepage: 110 | https://pjcj.net 111 | 112 | =cut 113 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO/JSON.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2011-2025, 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 | # https://pjcj.net 7 | 8 | package Devel::Cover::DB::IO::JSON; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use base "Devel::Cover::DB::IO::Base"; 14 | 15 | use JSON::MaybeXS (); 16 | 17 | # VERSION 18 | 19 | sub new { 20 | my $class = shift; 21 | my %args = @_; 22 | my $json = JSON::MaybeXS->new(utf8 => 1, allow_blessed => 1); 23 | $json->ascii->pretty->canonical 24 | if exists $args{options} && $args{options} =~ /\bpretty\b/i; 25 | my $self = $class->SUPER::new(%args, json => $json); 26 | bless $self, $class 27 | } 28 | 29 | sub read { 30 | my $self = shift; 31 | my ($file) = @_; 32 | $self->_read_fh( 33 | $file, 34 | sub { 35 | my ($fh) = @_; 36 | local $/; 37 | my $data = eval { $self->{json}->decode(<$fh>) }; 38 | die "Can't read $file with ", (ref $self->{json}), ": $@" if $@; 39 | $data 40 | } 41 | ) 42 | } 43 | 44 | sub write { 45 | my $self = shift; 46 | my ($data, $file) = @_; 47 | $self->_write_fh( 48 | $file, 49 | sub { 50 | my ($fh) = @_; 51 | print $fh $self->{json}->encode($data); 52 | } 53 | ) 54 | } 55 | 56 | 1 57 | 58 | __END__ 59 | 60 | =head1 NAME 61 | 62 | Devel::Cover::DB::IO::JSON - JSON based IO routines for Devel::Cover::DB 63 | 64 | =head1 SYNOPSIS 65 | 66 | use Devel::Cover::DB::IO::JSON; 67 | 68 | my $io = Devel::Cover::DB::IO::JSON->new; 69 | my $data = $io->read($file); 70 | $io->write($data, $file); 71 | 72 | =head1 DESCRIPTION 73 | 74 | This module provides JSON based IO routines for Devel::Cover::DB. 75 | 76 | =head1 SEE ALSO 77 | 78 | L 79 | L 80 | 81 | =head1 METHODS 82 | 83 | =head2 new 84 | 85 | my $io = Devel::Cover::DB::IO::JSON->new; 86 | 87 | Constructs the IO object. 88 | 89 | =head2 read 90 | 91 | my $data = $io->read($file); 92 | 93 | Returns a perl data structure representing the data read from $file. 94 | 95 | =head2 write 96 | 97 | $io->write($data, $file); 98 | 99 | Writes $data to $file in the format specified when creating $io. 100 | 101 | =head1 BUGS 102 | 103 | Huh? 104 | 105 | =head1 LICENCE 106 | 107 | Copyright 2011-2025, Paul Johnson (paul@pjcj.net) 108 | 109 | This software is free. It is licensed under the same terms as Perl itself. 110 | 111 | The latest version of this software should be available from my homepage: 112 | https://pjcj.net 113 | 114 | =cut 115 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO/Sereal.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2014-2025, 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 | # https://pjcj.net 7 | 8 | package Devel::Cover::DB::IO::Sereal; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use base "Devel::Cover::DB::IO::Base"; 14 | 15 | use Sereal::Decoder; 16 | use Sereal::Encoder; 17 | 18 | # VERSION 19 | 20 | my ($Decoder, $Encoder); 21 | 22 | sub new { 23 | my $class = shift; 24 | my $self = $class->SUPER::new(@_); 25 | bless $self, $class 26 | } 27 | 28 | sub read { 29 | my $self = shift; 30 | my ($file) = @_; 31 | $self->_read_fh( 32 | $file, 33 | sub { 34 | my ($fh) = @_; 35 | local $/; 36 | my $data 37 | = eval { ($Decoder ||= Sereal::Decoder->new({}))->decode(<$fh>) }; 38 | die "Can't read $file with Sereal: $@" if $@; 39 | $data 40 | } 41 | ) 42 | } 43 | 44 | sub write { 45 | my $self = shift; 46 | my ($data, $file) = @_; 47 | $self->_write_fh( 48 | $file, 49 | sub { 50 | my ($fh) = @_; 51 | print $fh ($Encoder ||= Sereal::Encoder->new({}))->encode($data); 52 | } 53 | ) 54 | } 55 | 56 | 1 57 | 58 | __END__ 59 | 60 | =head1 NAME 61 | 62 | Devel::Cover::DB::IO::Sereal - Sereal based IO routines for Devel::Cover::DB 63 | 64 | =head1 SYNOPSIS 65 | 66 | use Devel::Cover::DB::IO::Sereal; 67 | 68 | my $io = Devel::Cover::DB::IO::Sereal->new; 69 | my $data = $io->read($file); 70 | $io->write($data, $file); 71 | 72 | =head1 DESCRIPTION 73 | 74 | This module provides Sereal based IO routines for Devel::Cover::DB. 75 | 76 | =head1 SEE ALSO 77 | 78 | Devel::Cover 79 | 80 | =head1 METHODS 81 | 82 | =head2 new 83 | 84 | my $io = Devel::Cover::DB::IO::Sereal->new; 85 | 86 | Constructs the IO object. 87 | 88 | =head2 read 89 | 90 | my $data = $io->read($file); 91 | 92 | Returns a perl data structure representing the data read from $file. 93 | 94 | =head2 write 95 | 96 | $io->write($data, $file); 97 | 98 | Writes $data to $file in the format specified when creating $io. 99 | 100 | =head1 BUGS 101 | 102 | Huh? 103 | 104 | =head1 LICENCE 105 | 106 | Copyright 2011-2025, Paul Johnson (paul@pjcj.net) 107 | 108 | This software is free. It is licensed under the same terms as Perl itself. 109 | 110 | The latest version of this software should be available from my homepage: 111 | https://pjcj.net 112 | 113 | =cut 114 | -------------------------------------------------------------------------------- /lib/Devel/Cover/DB/IO/Storable.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2011-2025, 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 | # https://pjcj.net 7 | 8 | package Devel::Cover::DB::IO::Storable; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use base "Devel::Cover::DB::IO::Base"; 14 | 15 | use Storable; 16 | 17 | # VERSION 18 | 19 | sub new { 20 | my $class = shift; 21 | my $self = $class->SUPER::new(@_); 22 | bless $self, $class 23 | } 24 | 25 | sub read { 26 | my $self = shift; 27 | my ($file) = @_; 28 | $self->_read($file, sub { Storable::retrieve($file) }) 29 | } 30 | 31 | sub write { 32 | my $self = shift; 33 | my ($data, $file) = @_; 34 | $self->_write($file, sub { Storable::nstore($data, $file) }) 35 | } 36 | 37 | 1 38 | 39 | __END__ 40 | 41 | =head1 NAME 42 | 43 | Devel::Cover::DB::IO::Storable - Storable based IO routines for Devel::Cover::DB 44 | 45 | =head1 SYNOPSIS 46 | 47 | use Devel::Cover::DB::IO::Storable; 48 | 49 | my $io = Devel::Cover::DB::IO::Storable->new; 50 | my $data = $io->read($file); 51 | $io->write($data, $file); 52 | 53 | =head1 DESCRIPTION 54 | 55 | This module provides Storable based IO routines for Devel::Cover::DB. 56 | 57 | =head1 SEE ALSO 58 | 59 | Devel::Cover 60 | 61 | =head1 METHODS 62 | 63 | =head2 new 64 | 65 | my $io = Devel::Cover::DB::IO::Storable->new; 66 | 67 | Constructs the IO object. 68 | 69 | =head2 read 70 | 71 | my $data = $io->read($file); 72 | 73 | Returns a perl data structure representing the data read from $file. 74 | 75 | =head2 write 76 | 77 | $io->write($data, $file); 78 | 79 | Writes $data to $file in the format specified when creating $io. 80 | 81 | =head1 BUGS 82 | 83 | Huh? 84 | 85 | =head1 LICENCE 86 | 87 | Copyright 2011-2025, 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 | https://pjcj.net 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /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 | # https://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 | no warnings "once"; 31 | local $Data::Dumper::Indent = 1; 32 | local $Data::Dumper::Sortkeys = 1; 33 | Data::Dumper::Dumper(@_); 34 | } 35 | 36 | 1 37 | 38 | __END__ 39 | 40 | =encoding utf8 41 | 42 | =head1 NAME 43 | 44 | Devel::Cover::Dumper - Internal module for debugging purposes 45 | 46 | =head1 SYNOPSIS 47 | 48 | use Devel::Cover::Dumper; 49 | 50 | print Dumper $x; 51 | 52 | =head1 DESCRIPTION 53 | 54 | Wrapper around Data::Dumper::Dumper. 55 | 56 | =head1 SEE ALSO 57 | 58 | Devel::Cover 59 | 60 | =head1 METHODS 61 | 62 | =head1 BUGS 63 | 64 | Huh? 65 | 66 | =head1 LICENCE 67 | 68 | Copyright 2012, Olivier Mengué 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 | https://pjcj.net 74 | 75 | =cut 76 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Html_Common.pm: -------------------------------------------------------------------------------- 1 | package Devel::Cover::Html_Common; 2 | 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 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Pod.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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]->simple_error } 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) if $self->covered; 36 | $self->aggregate($s, $file, 'error', $self->error); 37 | } 38 | 39 | 1 40 | 41 | __END__ 42 | 43 | =head1 NAME 44 | 45 | Devel::Cover::Pod - Code coverage metrics for Perl 46 | 47 | =head1 SYNOPSIS 48 | 49 | use Devel::Cover::Pod; 50 | 51 | =head1 DESCRIPTION 52 | 53 | Module for storing pod coverage information. 54 | 55 | =head1 SEE ALSO 56 | 57 | Devel::Cover::Criterion 58 | 59 | =head1 METHODS 60 | 61 | =head1 BUGS 62 | 63 | Huh? 64 | 65 | =head1 LICENCE 66 | 67 | Copyright 2001-2025, Paul Johnson (paul@pjcj.net) 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 | https://pjcj.net 73 | 74 | =cut 75 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Report/Html.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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-2025, 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 | https://pjcj.net 52 | 53 | =cut 54 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Report/Json.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2014-2025, 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 | # https://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 | my ($db) = @_; 20 | my @runs; 21 | for my $r (sort { $a->{start} <=> $b->{start} } $db->runs) { 22 | push @runs, 23 | { map { $_ => $r->$_ } 24 | qw( run perl OS dir name version abstract start finish ) }; 25 | } 26 | \@runs 27 | } 28 | 29 | sub report { 30 | my ($pkg, $db, $options) = @_; 31 | 32 | my %options = map { $_ => 1 } grep !/path|time/, $db->all_criteria, "force"; 33 | $db->calculate_summary(%options); 34 | 35 | my $json = { runs => add_runs($db), summary => $db->{summary} }; 36 | # print "JSON: ", Dumper $json; 37 | print "JSON sent to $options->{outputdir}/cover.json\n"; 38 | 39 | my $io = Devel::Cover::DB::IO::JSON->new(options => "pretty"); 40 | $io->write($json, "$options->{outputdir}/cover.json"); 41 | } 42 | 43 | 1 44 | 45 | __END__ 46 | 47 | =head1 NAME 48 | 49 | Devel::Cover::Report::Json - JSON backend for Devel::Cover 50 | 51 | =head1 SYNOPSIS 52 | 53 | cover -report json 54 | 55 | =head1 DESCRIPTION 56 | 57 | This module provides JSON output for coverage data. 58 | It is designed to be called from the C program. 59 | 60 | =head1 SEE ALSO 61 | 62 | Devel::Cover 63 | 64 | =head1 BUGS 65 | 66 | Huh? 67 | 68 | =head1 LICENCE 69 | 70 | Copyright 2014-2025, Paul Johnson (paul@pjcj.net) 71 | 72 | This software is free. It is licensed under the same terms as Perl itself. 73 | 74 | The latest version of this software should be available from my homepage: 75 | https://pjcj.net 76 | 77 | =cut 78 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Report/Sort.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2025, 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 | # https://pjcj.net 7 | 8 | package Devel::Cover::Report::Sort; 9 | 10 | use strict; 11 | use warnings; 12 | 13 | # VERSION 14 | 15 | use Devel::Cover::DB; 16 | 17 | sub print_sort { 18 | my ($db, $options) = @_; 19 | my %runs; 20 | my @collected = grep $_ ne "time", @{ $options->{coverage} }; 21 | # use Devel::Cover::Dumper; print Dumper [$db->runs]; 22 | for my $r (sort { $a->{start} <=> $b->{start} } $db->runs) { 23 | print "Run: ", $r->run, "\n"; 24 | print "Perl version: ", $r->perl, "\n"; 25 | print "OS: ", $r->OS, "\n"; 26 | print "Start: ", scalar gmtime $r->start / 1e6, "\n"; 27 | print "Finish: ", scalar gmtime $r->finish / 1e6, "\n"; 28 | # use Devel::Cover::Dumper; print Dumper $r; 29 | 30 | @{ $runs{ $r->run } }{ "vec", "size" } = ("", 0); 31 | my $run = $runs{ $r->run }; 32 | # use Devel::Cover::Dumper; print Dumper $run; 33 | my $vec = $r->vec; 34 | for my $file (@{ $options->{file} }) { 35 | # print "$file\n"; 36 | for my $criterion (@collected) { 37 | my ($v, $sz) = @{ $vec->{$file}{$criterion} }{ "vec", "size" }; 38 | $sz |= 0; 39 | printf "$file:%10s %5d: ", $criterion, $sz; 40 | unless ($sz) { 41 | print "\n"; 42 | next; 43 | } 44 | for (0 .. $sz - 1) { 45 | print vec $v, $_, 1; 46 | vec($run->{vec}, $run->{size}++, 1) = vec $v, $_, 1; 47 | } 48 | print "\n"; 49 | } 50 | } 51 | $run->{count} += vec $run->{vec}, $_, 1 for 0 .. $run->{size} - 1; 52 | print "Vec: "; 53 | print vec $run->{vec}, $_, 1 for 0 .. $run->{size} - 1; 54 | print "\n"; 55 | print "Count: $run->{count} / $run->{size}\n\n"; 56 | } 57 | } 58 | 59 | sub report { 60 | my ($pkg, $db, $options) = @_; 61 | print_sort($db, $options); 62 | } 63 | 64 | 1 65 | 66 | __END__ 67 | 68 | =head1 NAME 69 | 70 | Devel::Cover::Report::Sort - backend for Devel::Cover 71 | 72 | =head1 SYNOPSIS 73 | 74 | cover -report sort 75 | 76 | =head1 DESCRIPTION 77 | 78 | This module reports coverage runs in an optimal order. 79 | It is designed to be called from the C program. 80 | 81 | =head1 SEE ALSO 82 | 83 | Devel::Cover 84 | 85 | =head1 BUGS 86 | 87 | Huh? 88 | 89 | =head1 LICENCE 90 | 91 | Copyright 2004-2025, Paul Johnson (paul@pjcj.net) 92 | 93 | This software is free. It is licensed under the same terms as Perl itself. 94 | 95 | The latest version of this software should be available from my homepage: 96 | https://pjcj.net 97 | 98 | =cut 99 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Statement.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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]->simple_error } 23 | sub criterion { "statement" } 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 statement 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 2001-2025, 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 | https://pjcj.net 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Subroutine.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2025, 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 | # https://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]->simple_error } 22 | sub name { $_[0][1] } 23 | sub criterion { "subroutine" } 24 | 25 | 1 26 | 27 | __END__ 28 | 29 | =head1 NAME 30 | 31 | Devel::Cover::Subroutine - Code coverage metrics for Perl subroutines 32 | 33 | =head1 SYNOPSIS 34 | 35 | use Devel::Cover::Subroutine; 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-2025, 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 | https://pjcj.net 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Time.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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 | Constructs the DB from the specified database. 65 | 66 | =head1 BUGS 67 | 68 | Huh? 69 | 70 | =head1 LICENCE 71 | 72 | Copyright 2001-2025, 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 | https://pjcj.net 78 | 79 | =cut 80 | -------------------------------------------------------------------------------- /lib/Devel/Cover/Util.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2001-2025, 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 | # https://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 normalise 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 $_; # normalise 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-2025, 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 | https://pjcj.net 85 | 86 | =cut 87 | -------------------------------------------------------------------------------- /t/internal/criteria.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | require Devel::Cover; 7 | Devel::Cover->import(qw( -silent 1 )); 8 | plan tests => 5; 9 | 10 | Devel::Cover::set_coverage("none"); 11 | is Devel::Cover::get_coverage(), 12 | "", 13 | "Set coverage to none empties coverage"; 14 | 15 | Devel::Cover::set_coverage("all"); 16 | is Devel::Cover::get_coverage(), 17 | "branch condition path pod statement subroutine time", 18 | "Set coverage to all fills coverage"; 19 | 20 | Devel::Cover::remove_coverage("path"); 21 | is Devel::Cover::get_coverage(), 22 | "branch condition pod statement subroutine time", 23 | "Removing path coverage works"; 24 | 25 | { 26 | my $warning; 27 | local $SIG{__WARN__} = sub { $warning = shift }; 28 | Devel::Cover::add_coverage("does_not_exist"); 29 | like $warning, 30 | qr/Devel::Cover: Unknown coverage criterion "does_not_exist" ignored./, 31 | "Adding nonexistent coverage warns"; 32 | } 33 | is Devel::Cover::get_coverage(), 34 | "branch condition pod statement subroutine time", 35 | "Adding nonexistent coverage has no effect"; 36 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /t/internal/inc_filter/cwd/lib/.dummy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjcj/Devel--Cover/90c735b84b12a48d1b81eb44a95363750e35dd68/t/internal/inc_filter/cwd/lib/.dummy -------------------------------------------------------------------------------- /t/internal/inc_filter/cwd_lib/.dummy: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjcj/Devel--Cover/90c735b84b12a48d1b81eb44a95363750e35dd68/t/internal/inc_filter/cwd_lib/.dummy -------------------------------------------------------------------------------- /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 | { 11 | local $SIG{__WARN__} = sub {}; 12 | eval "use HTML::Entities; 1"; 13 | if ($@) { 14 | plan skip_all => "No HTML::Entities"; 15 | exit; 16 | } 17 | } 18 | 19 | plan tests => scalar @reporters; 20 | 21 | my @reporters_with_launch = qw( 22 | Html Html_basic Html_minimal Html_subtle 23 | ); 24 | 25 | # Check that the expected reporters support the launch feature 26 | for my $reporter (@reporters) { 27 | my $class = 'Devel::Cover::Report::' . $reporter; 28 | eval "require $class"; 29 | 30 | if (grep { $_ eq $reporter } @reporters_with_launch) { 31 | ok($class->can('launch'), "$reporter supports launch"); 32 | } 33 | else { 34 | ok(! $class->can('launch'), "$reporter does not support launch"); 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /t/internal/subprocess.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | if ($] < 5.010000) { 7 | plan skip_all => "Perl version $] is not supported"; 8 | } else { 9 | plan tests => 2; 10 | } 11 | 12 | my $cmd = qq[$^X -e "print q(Hello, world.)"]; 13 | my $output = `$cmd 2>&1`; 14 | is($output, "Hello, world.", "simple test with perl -e"); 15 | 16 | $cmd = qq[$^X -Mblib -MDevel::Cover=-silent,1 -e "print q(Hello, world.)"]; 17 | $output = `$cmd 2>&1`; 18 | is($output, "Hello, world.", "test with perl -MDevel::Cover,-silent,1 -e"); 19 | -------------------------------------------------------------------------------- /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/alias.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/bigint.5.032000: -------------------------------------------------------------------------------- 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-2025, 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 # https://pjcj.net 29 | 9 30 | 10 # __COVER__ skip_test $] < 5.032 31 | 11 # __COVER__ skip_reason Too fragile below 5.32 32 | 12 33 | 13 1 1 use strict; 34 | 1 35 | 1 36 | 14 1 1 use warnings; 37 | 1 38 | 1 39 | 15 40 | 16 1 1 use Math::BigInt ":constant"; 41 | 1 42 | 1 43 | 17 44 | 18 1 my $x = 1; 45 | 19 *** 1 * 50 print $x if 1 >= $x; 46 | 47 | 48 | Branches 49 | -------- 50 | 51 | line err % true false branch 52 | ----- --- ------ ------ ------ ------ 53 | 19 *** 50 1 0 if bless( {"sign" => "+","value" => bless( [1], 'Math::BigInt::Calc' )}, 'Math::BigInt' ) >= $x 54 | 55 | 56 | Covered Subroutines 57 | ------------------- 58 | 59 | Subroutine Count Location 60 | ---------- ----- --------------- 61 | BEGIN 1 tests/bigint:13 62 | BEGIN 1 tests/bigint:14 63 | BEGIN 1 tests/bigint:16 64 | 65 | 66 | -------------------------------------------------------------------------------- /test_output/cover/change.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /test_output/cover/circular_ref.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------ ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------ ------ ------ ------ ------ ------ 7 | tests/circular_ref 83.3 0.0 n/a 66.6 63.6 8 | Total 83.3 0.0 n/a 66.6 63.6 9 | ------------------ ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/circular_ref 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 1 my $VAR1; 24 | 4 1 1 BEGIN { $VAR1 = \$VAR1 } 25 | 5 1 1 use constant MyType => $VAR1; 26 | 1 27 | 1 28 | 6 29 | 7 sub f { 30 | 8 *** *0 * 0 *0 return MyType if @_; 31 | 9 } 32 | 33 | 34 | Branches 35 | -------- 36 | 37 | line err % true false branch 38 | ----- --- ------ ------ ------ ------ 39 | 8 *** 0 0 0 if @_ 40 | 41 | 42 | Covered Subroutines 43 | ------------------- 44 | 45 | Subroutine Count Location 46 | ---------- ----- -------------------- 47 | BEGIN 1 tests/circular_ref:4 48 | BEGIN 1 tests/circular_ref:5 49 | 50 | Uncovered Subroutines 51 | --------------------- 52 | 53 | Subroutine Count Location 54 | ---------- ----- -------------------- 55 | f 0 tests/circular_ref:8 56 | 57 | 58 | -------------------------------------------------------------------------------- /test_output/cover/cop.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /test_output/cover/default_param.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /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-2025, 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 # https://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/deparse.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/destroy.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/empty.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ----- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ----- ------ ------ ------ ------ ------ 7 | Total n/a n/a n/a n/a n/a 8 | ----- ------ ------ ------ ------ ------ 9 | 10 | 11 | Run: ... 12 | Perl version: ... 13 | OS: ... 14 | Start: ... 15 | Finish: ... 16 | 17 | -------------------------------------------------------------------------------- /test_output/cover/end_constant.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ----- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ----- ------ ------ ------ ------ ------ 7 | Total n/a n/a n/a n/a n/a 8 | ----- ------ ------ ------ ------ ------ 9 | 10 | 11 | Run: ... 12 | Perl version: ... 13 | OS: ... 14 | Start: ... 15 | Finish: ... 16 | 17 | -------------------------------------------------------------------------------- /test_output/cover/eval_nested.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/exec.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/exec_die.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /test_output/cover/final_op.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | Devel::Cover: Can't find digest for tests/final_op 3 | 4 | 5 | ----- ------ ------ ------ ------ ------ 6 | File stmt bran cond sub total 7 | ----- ------ ------ ------ ------ ------ 8 | Total n/a n/a n/a n/a n/a 9 | ----- ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | -------------------------------------------------------------------------------- /test_output/cover/fork.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://pjcj.net 35 | 9 36 | 10 # __COVER__ skip_test $^O eq "MSWin32" 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/md5.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://pjcj.net 36 | 9 37 | 10 1 my $x = 1; 38 | 39 | 40 | -------------------------------------------------------------------------------- /test_output/cover/moose_basic.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /test_output/cover/moose_constraint.5.016000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ---------------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ---------------------- ------ ------ ------ ------ ------ 7 | tests/moose_constraint 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_constraint 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2011-2025, 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 # https://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 1 1 use 5.010; 34 | 1 35 | 14 36 | 15 package Foo; 37 | 16 38 | 17 1 1 use Moose; 39 | 1 40 | 1 41 | 18 42 | 19 1 has bar => ( 43 | 20 is => 'rw', 44 | 21 isa => 'Maybe[Str]', 45 | 22 ); 46 | 23 47 | 24 package main; 48 | 25 49 | 26 1 my $example = Foo->new(); 50 | 27 1 $example->bar('whatever'); 51 | 28 1 say $example->bar(); 52 | 53 | 54 | Covered Subroutines 55 | ------------------- 56 | 57 | Subroutine Count Location 58 | ---------- ----- ------------------------- 59 | BEGIN 1 tests/moose_constraint:13 60 | BEGIN 1 tests/moose_constraint:17 61 | 62 | 63 | -------------------------------------------------------------------------------- /test_output/cover/overload_bool2.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 { 38 | 14 1 package Cat; 39 | 15 40 | 16 1 1 use overload (bool => "meh"); 41 | 1 42 | 1 43 | 17 44 | 18 3 3 sub meh { 1 } 45 | 19 } 46 | 20 47 | 21 1 my $string = "hi"; 48 | 22 1 my $x = bless \$string, "Cat"; 49 | 23 50 | 24 1 my $fn = eval 'require $x'; 51 | 52 | 53 | Covered Subroutines 54 | ------------------- 55 | 56 | Subroutine Count Location 57 | ---------- ----- ----------------------- 58 | BEGIN 1 tests/overload_bool2:10 59 | BEGIN 1 tests/overload_bool2:11 60 | BEGIN 1 tests/overload_bool2:16 61 | meh 3 tests/overload_bool2:18 62 | 63 | 64 | -------------------------------------------------------------------------------- /test_output/cover/overload_bool2.5.022000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | -------------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | -------------------- ------ ------ ------ ------ ------ 7 | tests/overload_bool2 93.3 n/a n/a 100.0 94.7 8 | Total 93.3 n/a n/a 100.0 94.7 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-2025, 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 # https://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 { 38 | 14 *** *0 package Cat; 39 | 15 40 | 16 1 1 use overload (bool => "meh"); 41 | 1 42 | 1 43 | 17 44 | 18 3 3 sub meh { 1 } 45 | 19 } 46 | 20 47 | 21 1 my $string = "hi"; 48 | 1 49 | 22 1 my $x = bless \$string, "Cat"; 50 | 23 51 | 24 1 my $fn = eval 'require $x'; 52 | 53 | 54 | Covered Subroutines 55 | ------------------- 56 | 57 | Subroutine Count Location 58 | ---------- ----- ----------------------- 59 | BEGIN 1 tests/overload_bool2:10 60 | BEGIN 1 tests/overload_bool2:11 61 | BEGIN 1 tests/overload_bool2:16 62 | meh 3 tests/overload_bool2:18 63 | 64 | 65 | -------------------------------------------------------------------------------- /test_output/cover/overload_bool2.5.038000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | -------------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | -------------------- ------ ------ ------ ------ ------ 7 | tests/overload_bool2 93.3 n/a n/a 100.0 94.7 8 | Total 93.3 n/a n/a 100.0 94.7 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-2025, 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 # https://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 { 38 | 14 *** *0 package Cat; 39 | 15 40 | 16 1 1 use overload (bool => "meh"); 41 | 1 42 | 1 43 | 17 44 | 18 2 2 sub meh { 1 } 45 | 19 } 46 | 20 47 | 21 1 my $string = "hi"; 48 | 1 49 | 22 1 my $x = bless \$string, "Cat"; 50 | 23 51 | 24 1 my $fn = eval 'require $x'; 52 | 53 | 54 | Covered Subroutines 55 | ------------------- 56 | 57 | Subroutine Count Location 58 | ---------- ----- ----------------------- 59 | BEGIN 1 tests/overload_bool2:10 60 | BEGIN 1 tests/overload_bool2:11 61 | BEGIN 1 tests/overload_bool2:16 62 | meh 2 tests/overload_bool2:18 63 | 64 | 65 | -------------------------------------------------------------------------------- /test_output/cover/padrange.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://pjcj.net 29 | 9 30 | 10 1 my $a; 31 | 11 1 my ($b, $c); 32 | 12 1 my ($d); 33 | 13 1 my @s; 34 | 14 1 for (@s) {} 35 | 36 | 37 | -------------------------------------------------------------------------------- /test_output/cover/padrange2.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | --------------- ------ ------ ------ ------ ------ 7 | tests/padrange2 100.0 50.0 n/a 100.0 90.9 8 | Total 100.0 50.0 n/a 100.0 90.9 9 | --------------- ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange2 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 1 1 use strict; 24 | 1 25 | 1 26 | 4 1 1 use warnings; 27 | 1 28 | 1 29 | 5 30 | 6 *** 1 * 50 if (my @x = 'foo' =~ m/(.)/) { 31 | 7 } else { 32 | 8 } 33 | 34 | 35 | Branches 36 | -------- 37 | 38 | line err % true false branch 39 | ----- --- ------ ------ ------ ------ 40 | 6 *** 50 1 0 if (my(@x) = 'foo' =~ /(.)/) { } 41 | 42 | 43 | Covered Subroutines 44 | ------------------- 45 | 46 | Subroutine Count Location 47 | ---------- ----- ----------------- 48 | BEGIN 1 tests/padrange2:3 49 | BEGIN 1 tests/padrange2:4 50 | 51 | 52 | -------------------------------------------------------------------------------- /test_output/cover/padrange2.5.018000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | --------------- ------ ------ ------ ------ ------ 7 | tests/padrange2 100.0 50.0 n/a 100.0 90.9 8 | Total 100.0 50.0 n/a 100.0 90.9 9 | --------------- ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange2 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 1 1 use strict; 24 | 1 25 | 1 26 | 4 1 1 use warnings; 27 | 1 28 | 1 29 | 5 30 | 6 *** 1 * 50 if (my @x = 'foo' =~ m/(.)/) { 31 | 7 } else { 32 | 8 } 33 | 34 | 35 | Branches 36 | -------- 37 | 38 | line err % true false branch 39 | ----- --- ------ ------ ------ ------ 40 | 6 *** 50 1 0 if ((XXX) = 'foo' =~ /(.)/) { } 41 | 42 | 43 | Covered Subroutines 44 | ------------------- 45 | 46 | Subroutine Count Location 47 | ---------- ----- ----------------- 48 | BEGIN 1 tests/padrange2:3 49 | BEGIN 1 tests/padrange2:4 50 | 51 | 52 | -------------------------------------------------------------------------------- /test_output/cover/padrange2.5.022000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | --------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | --------------- ------ ------ ------ ------ ------ 7 | tests/padrange2 100.0 50.0 n/a 100.0 90.9 8 | Total 100.0 50.0 n/a 100.0 90.9 9 | --------------- ------ ------ ------ ------ ------ 10 | 11 | 12 | Run: ... 13 | Perl version: ... 14 | OS: ... 15 | Start: ... 16 | Finish: ... 17 | 18 | tests/padrange2 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 1 1 use strict; 24 | 1 25 | 1 26 | 4 1 1 use warnings; 27 | 1 28 | 1 29 | 5 30 | 6 *** 1 * 50 if (my @x = 'foo' =~ m/(.)/) { 31 | 7 } else { 32 | 8 } 33 | 34 | 35 | Branches 36 | -------- 37 | 38 | line err % true false branch 39 | ----- --- ------ ------ ------ ------ 40 | 6 *** 50 1 0 if (my(@x) = 'foo' =~ /(.)/) { } 41 | 42 | 43 | Covered Subroutines 44 | ------------------- 45 | 46 | Subroutine Count Location 47 | ---------- ----- ----------------- 48 | BEGIN 1 tests/padrange2:3 49 | BEGIN 1 tests/padrange2:4 50 | 51 | 52 | -------------------------------------------------------------------------------- /test_output/cover/pod.5.012000: -------------------------------------------------------------------------------- 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:24 64 | 65 | 66 | -------------------------------------------------------------------------------- /test_output/cover/pod_nocp.5.012000: -------------------------------------------------------------------------------- 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:24 64 | 65 | 66 | -------------------------------------------------------------------------------- /test_output/cover/recursive_sub.5.016000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ------------------- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ------------------- ------ ------ ------ ------ ------ 7 | tests/recursive_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/recursive_sub 19 | 20 | line err stmt bran cond sub code 21 | 1 #!/usr/bin/perl 22 | 2 23 | 3 # Copyright 2022-2025, 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 # https://pjcj.net 29 | 9 30 | 10 # __COVER__ skip_test $] < 5.016 31 | 11 # __COVER__ skip_reason __SUB__ is available from 5.16 32 | 12 33 | 13 1 1 use feature "current_sub"; 34 | 1 35 | 1 36 | 14 37 | 15 sub recursive_func 38 | 16 { 39 | 17 4 4 my ($ref) = @_; 40 | 18 4 100 return $ref unless ref $ref eq "ARRAY"; 41 | 19 3 return __SUB__->($ref->[0]); 42 | 20 } 43 | 21 44 | 22 1 recursive_func([[[]]]); 45 | 46 | 47 | Branches 48 | -------- 49 | 50 | line err % true false branch 51 | ----- --- ------ ------ ------ ------ 52 | 18 100 1 3 unless ref $ref eq "ARRAY" 53 | 54 | 55 | Covered Subroutines 56 | ------------------- 57 | 58 | Subroutine Count Location 59 | -------------- ----- ---------------------- 60 | BEGIN 1 tests/recursive_sub:13 61 | recursive_func 4 tests/recursive_sub:17 62 | 63 | 64 | -------------------------------------------------------------------------------- /test_output/cover/redefine_sub.5.012000: -------------------------------------------------------------------------------- 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/skip.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/statement.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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 | -------------------------------------------------------------------------------- /test_output/cover/subs_only.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/t1.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/taint.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://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/trivial.5.012000: -------------------------------------------------------------------------------- 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-2025, 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 # https://pjcj.net 29 | 9 30 | 10 1 my $x = 1; 31 | 32 | 33 | -------------------------------------------------------------------------------- /test_output/cover/xor_constant_fold.5.012000: -------------------------------------------------------------------------------- 1 | Reading database from ... 2 | 3 | 4 | ----- ------ ------ ------ ------ ------ 5 | File stmt bran cond sub total 6 | ----- ------ ------ ------ ------ ------ 7 | Total n/a n/a n/a n/a n/a 8 | ----- ------ ------ ------ ------ ------ 9 | 10 | 11 | Run: ... 12 | Perl version: ... 13 | OS: ... 14 | Start: ... 15 | Finish: ... 16 | 17 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tests/Accessor_maker.pm: -------------------------------------------------------------------------------- 1 | package Accessor_maker; 2 | 3 | sub import { 4 | no strict 'refs'; 5 | *{ caller() . '::' . 'foo' } = sub { $_[0]->{'foo'} }; 6 | } 7 | 1; 8 | -------------------------------------------------------------------------------- /tests/Alias1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2025, 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 | # https://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/COP.pm: -------------------------------------------------------------------------------- 1 | #line 64 "Parser.yp" 2 | 1; 3 | -------------------------------------------------------------------------------- /tests/E2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2004-2025, 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 | # https://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-2025, 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 | # https://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-2025, 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 | # https://pjcj.net 7 | 8 | package E4; 9 | 10 | print "E4\n"; 11 | 12 | sub E4 { print "E4::E4\n" } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/IncSub.pm: -------------------------------------------------------------------------------- 1 | package IncSub; 2 | 3 | sub check { print "***********\n" } 4 | 5 | 1 6 | -------------------------------------------------------------------------------- /tests/Module1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2025, 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 | # https://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/Module2.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2025, 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 | # https://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/Module_import.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2002-2025, 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 | # https://pjcj.net 7 | 8 | package Module_import; 9 | 10 | sub import { 11 | print "Module_import\n"; 12 | } 13 | 14 | 1 15 | -------------------------------------------------------------------------------- /tests/PodMod.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2005-2025, 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 | # https://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/Taint.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2013-2025, 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 | # https://pjcj.net 7 | 8 | package Taint; 9 | 10 | eval 1 unless defined &X; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /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/alias: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/alias1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/and: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2013-2025, 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 | # https://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 | if (!$x || !$y) { 29 | die "Urgh"; 30 | } 31 | -------------------------------------------------------------------------------- /tests/any_all: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.041010 11 | # __COVER__ skip_reason any/all not implemented 12 | 13 | use strict; 14 | use warnings; 15 | no warnings "experimental"; 16 | use feature "keyword_any"; 17 | use feature "keyword_all"; 18 | 19 | sub main { 20 | my $haystack = [ 1 .. 8 ]; 21 | print "any\n" if any { $_ % 2 } @$haystack; 22 | print "all\n" if all { $_ < 9 } @$haystack; 23 | } 24 | 25 | main 26 | -------------------------------------------------------------------------------- /tests/bigint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.032 11 | # __COVER__ skip_reason Too fragile below 5.32 12 | 13 | use strict; 14 | use warnings; 15 | 16 | use Math::BigInt ":constant"; 17 | 18 | my $x = 1; 19 | print $x if 1 >= $x; 20 | -------------------------------------------------------------------------------- /tests/branch_return_sub: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/change.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use File::Copy; 14 | 15 | use Devel::Cover::Test; 16 | 17 | my $t = "change"; 18 | my $ft = "./tests/$t"; 19 | my $fg = "./tests/trivial"; 20 | 21 | my $run_test = sub { 22 | my $test = shift; 23 | 24 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 25 | $test->run_command($test->test_command); 26 | 27 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 28 | open T, ">>$ft" or die "Cannot open $ft: $!"; 29 | print T <<'EOT'; 30 | sub new_sub { 31 | my $y = 1; 32 | } 33 | 34 | new_sub; 35 | EOT 36 | close T or die "Cannot close $ft: $!"; 37 | 38 | $test->{test_parameters} .= " -merge 1"; 39 | $test->run_command($test->test_command); 40 | }; 41 | 42 | my $test = Devel::Cover::Test->new( 43 | $t, 44 | db_name => "complex_$t", 45 | run_test => $run_test, 46 | end => sub { unlink $ft }, 47 | no_report => 0, 48 | delay_after_run => 0.50, 49 | ); 50 | 51 | $test->run_test; 52 | no warnings; 53 | $test # for create_gold 54 | -------------------------------------------------------------------------------- /tests/circular_ref: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | my $VAR1; 4 | BEGIN { $VAR1 = \$VAR1 } 5 | use constant MyType => $VAR1; 6 | 7 | sub f { 8 | return MyType if @_; 9 | } 10 | -------------------------------------------------------------------------------- /tests/cond_and: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/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/cond_or: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $^O eq "cygwin" 11 | # __COVER__ skip_reason Busted on 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 | $ENV{PATH} = "/bin"; 23 | system "pwd"; 24 | use lib "tests"; 25 | my $file = "cond_or.pl"; 26 | unless (my $return = do $file) { 27 | die "couldn't parse $file: $@" if $@; 28 | die "couldn't do $file: $!" unless defined $return; 29 | die "couldn't run $file" unless $return; 30 | } 31 | 32 | for my $i (0 .. 10) { 33 | $y || 34 | $x[1]++; 35 | 36 | $y || 37 | $x[0]++ || 38 | $x[1]++; 39 | 40 | $x[2]++ 41 | unless $z; 42 | 43 | for (0 .. 2) { 44 | $x[3]++; 45 | } 46 | 47 | if ($z) { 48 | $x[4]++; 49 | } else { 50 | $x[5]++; 51 | } 52 | 53 | my $p = $y || $z; 54 | my $q = $z || $y; 55 | my $r = $i || "qqq"; 56 | my $s = $i || []; 57 | my $t = $y | $z; 58 | my $u = $y || 0; 59 | my $v = $y || undef; 60 | my $w = $z || 0; 61 | 62 | $p ||= $y; 63 | $p ||= $z; 64 | $x[ 6] ||= $y; 65 | $x[ 7] ||= $z; 66 | $x[ 8] ||= 1; 67 | $x[ 9] ||= {}; 68 | $x[10] ||= \"foo"; 69 | $x[11] ||= \$y; 70 | $x[12] ||= \*STDIO; 71 | $x[13] ||= sub { 1 }; 72 | $x[14] ||= *::foo{SCALAR}; 73 | $x[15] ||= *STDIO{IO}; 74 | $x[16] ||= bless {}, "XXX"; 75 | $x[17] ||= $i == 1; 76 | $w ||= ref($i) eq "SCALAR"; 77 | $x[18] ||= <<"EOD"; 78 | blah 79 | EOD 80 | cond_dor(\@x) if exists &cond_dor; 81 | sub { $x[19] ||= 1 }; 82 | } 83 | 84 | # print join(", ", @x), "\n"; 85 | -------------------------------------------------------------------------------- /tests/cond_or.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/cond_xor: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/cond_xor_hp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.040000 11 | # __COVER__ skip_reason ^^ not implemented 12 | 13 | use strict; 14 | use warnings; 15 | 16 | sub main { 17 | my $i = 1; 18 | my $j = 0; 19 | 20 | for my $y (0, 1, 1, 1) { 21 | for my $z (0, 0, 1) { 22 | my $x = $y ^ $z; 23 | $x = $y ^^ $z; 24 | 25 | my $p = $i ^^ $y; 26 | $p = $j ^^ $y; 27 | } 28 | } 29 | } 30 | 31 | main 32 | -------------------------------------------------------------------------------- /tests/cop: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use lib "tests"; 14 | 15 | $SIG{__WARN__} = sub { die @_ }; 16 | require COP; 17 | -------------------------------------------------------------------------------- /tests/dbm_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.014000 || !(eval "use DBM::Deep; 23") 11 | # __COVER__ skip_reason DBM::Deep not available or painful to install 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/default_param: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/deparse: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -l 2 | 3 | # Copyright 2004-2025, 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 | # https://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/destroy: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/dist/DC-Test-Dist/Makefile.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use ExtUtils::MakeMaker; 14 | 15 | # VERSION 16 | our $LVERSION = do { eval '$VERSION' || "0.001" }; # for development purposes 17 | 18 | $ExtUtils::MakeMaker::Verbose = 0; 19 | 20 | WriteMakefile( 21 | NAME => "DC::Test::Dist", 22 | VERSION => $LVERSION, 23 | AUTHOR => 'Paul Johnson ', 24 | ABSTRACT_FROM => "lib/DC/Test/Dist.pm", 25 | clean => { FILES => "cover_db" }, 26 | ); 27 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2012-2025, 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 | # https://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-2025, 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 | https://pjcj.net 61 | 62 | =cut 63 | -------------------------------------------------------------------------------- /tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2012-2025, 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 | # https://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-2025, 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 | https://pjcj.net 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /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/dynamic_subs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/empty: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2015-2025, 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 | # https://pjcj.net 9 | -------------------------------------------------------------------------------- /tests/end_constant: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2015-2025, 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 | # https://pjcj.net 9 | 10 | 7 11 | -------------------------------------------------------------------------------- /tests/eval1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use lib -d "t" ? "t" : ".."; 14 | 15 | my $x; 16 | 17 | eval <<'EOS'; 18 | sub e { 19 | $x++; 20 | $x 21 | } 22 | EOS 23 | 24 | eval <<'EOS'; 25 | sub f { 26 | $x++; 27 | $x 28 | } 29 | 30 | sub g { 31 | $x++; 32 | } 33 | 34 | sub h { 35 | $x++; 36 | } 37 | EOS 38 | 39 | e(); 40 | e(); 41 | e(); 42 | f(); 43 | f(); 44 | h(); 45 | h(); 46 | h(); 47 | -------------------------------------------------------------------------------- /tests/eval2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/eval3: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/eval_merge: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014-2025, 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 | # https://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/eval_merge.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | my $run_test = sub { 16 | my $test = shift; 17 | $test->{test_file_parameters} = "0"; 18 | $test->run_command($test->test_command); 19 | $test->{test_parameters} .= " -merge 1"; 20 | $test->{test_file_parameters} = "1"; 21 | $test->run_command($test->test_command); 22 | }; 23 | 24 | my $runs = 2; 25 | 26 | my $test = Devel::Cover::Test->new( 27 | "eval_merge", 28 | db_name => "complex_eval_merge", 29 | golden_test => "eval_merge.t", 30 | run_test => $run_test, 31 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 32 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 33 | ); 34 | 35 | $test->run_test; 36 | 37 | no warnings; 38 | $test # for create_gold 39 | -------------------------------------------------------------------------------- /tests/eval_merge_0: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014-2025, 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 | # https://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-2025, 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 | # https://pjcj.net 9 | 10 | use lib "tests"; 11 | 12 | use E3; 13 | use E4; 14 | 15 | E3::E3; 16 | E4::E4; 17 | -------------------------------------------------------------------------------- /tests/eval_merge_sep.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | my $run_test = sub { 16 | my $test = shift; 17 | $test->{test} = "eval_merge_0"; 18 | $test->run_command($test->test_command); 19 | $test->{test_parameters} .= " -merge 1"; 20 | $test->{test} = "eval_merge_1"; 21 | $test->run_command($test->test_command); 22 | }; 23 | 24 | my $runs = 2; 25 | 26 | my $test = Devel::Cover::Test->new( 27 | "eval_merge_sep", 28 | db_name => "complex_eval_merge_sep", 29 | golden_test => "eval_merge_sep.t", 30 | run_test => $run_test, 31 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 32 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 33 | ); 34 | 35 | $test->run_test; 36 | 37 | no warnings; 38 | $test # for create_gold 39 | -------------------------------------------------------------------------------- /tests/eval_nested: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://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/eval_string: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | my $i = 1; 6 | 7 | if ($i == 2) { 8 | print STDERR "hello\n"; 9 | } else { 10 | print STDERR "goodbye\n"; 11 | } 12 | 13 | eval { 14 | if ($i == 2) { 15 | print STDERR "hello\n"; 16 | } else { 17 | print STDERR "goodbye\n"; 18 | } 19 | }; 20 | 21 | eval <<'EOF'; 22 | if ($i == 2) { 23 | print STDERR "hello\n"; 24 | } else { 25 | print STDERR "goodbye\n"; 26 | } 27 | EOF 28 | 29 | sub ev { 30 | eval { 31 | if ($i == 2) { 32 | print STDERR "hello\n"; 33 | } else { 34 | print STDERR "goodbye\n"; 35 | } 36 | }; 37 | 38 | eval <<'EOF'; 39 | if ($i == 2) { 40 | print STDERR "hello\n"; 41 | } else { 42 | print STDERR "goodbye\n"; 43 | } 44 | EOF 45 | } 46 | 47 | ev; 48 | -------------------------------------------------------------------------------- /tests/eval_sub.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | my $run_test = sub { 16 | my $test = shift; 17 | 18 | $test->{test_file_parameters} = "5"; 19 | $test->run_command($test->test_command); 20 | 21 | $test->{test_parameters} .= " -merge 1"; 22 | 23 | $test->{test_file_parameters} = "5"; 24 | $test->run_command($test->test_command); 25 | 26 | $test->{test_file_parameters} = "7"; 27 | $test->run_command($test->test_command); 28 | 29 | $test->{test_file_parameters} = "0"; 30 | $test->run_command($test->test_command); 31 | }; 32 | 33 | my $runs = 4; 34 | 35 | my $test = Devel::Cover::Test->new( 36 | "eval3", 37 | db_name => "complex_eval_sub", 38 | golden_test => "eval_sub.t", 39 | run_test => $run_test, 40 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 41 | tests => sub { $_[0] - $runs * 6 }, # number of lines deleted above 42 | ); 43 | 44 | $test->run_test; 45 | no warnings; 46 | $test # for create_gold 47 | -------------------------------------------------------------------------------- /tests/eval_use.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Devel::Cover::Test; 14 | 15 | my $run_test = sub { 16 | my $test = shift; 17 | 18 | $test->run_command($test->test_command); 19 | 20 | $test->{test_parameters} .= " -merge 1"; 21 | 22 | $test->{test_file_parameters} = "5"; 23 | $test->run_command($test->test_command); 24 | 25 | $test->{test_file_parameters} = "7"; 26 | $test->run_command($test->test_command); 27 | 28 | $test->{test_file_parameters} = "0"; 29 | $test->run_command($test->test_command); 30 | }; 31 | 32 | my $test = Devel::Cover::Test->new( 33 | "eval2", 34 | db_name => "complex_eval_use", 35 | golden_test => "eval_use.t", 36 | run_test => $run_test, 37 | changes => [ 'if (/^Run: /) { $get_line->() for 1 .. 5; redo }' ], 38 | tests => sub { $_[0] - 24 }, # number of lines deleted above 39 | ); 40 | 41 | $test->run_test; 42 | no warnings; 43 | $test # for create_gold 44 | -------------------------------------------------------------------------------- /tests/exec: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2007-2025, 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 | # https://pjcj.net 9 | 10 | $x = 1; 11 | 12 | exec "echo foo"; 13 | 14 | die "Unreachable"; 15 | -------------------------------------------------------------------------------- /tests/exec_die: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://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/final_op: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2015-2025, 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 | # https://pjcj.net 9 | 10 | a; 11 | sub a {} 12 | -------------------------------------------------------------------------------- /tests/fork: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $^O eq "MSWin32" 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/if: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/inc_sub: -------------------------------------------------------------------------------- 1 | #!/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test 1 11 | # __COVER__ skip_reason depends too much on specific installed perl 12 | 13 | use lib (); 14 | 15 | BEGIN { 16 | lib->import( 17 | sub { 18 | print map("[$_]", @_), "\n"; 19 | return unless $_[1] eq "IncSub.pm"; 20 | my $fh; 21 | open $fh, "tests/IncSub.pm" or die $!; 22 | $fh 23 | } 24 | ) 25 | } 26 | 27 | use IncSub; 28 | 29 | BEGIN { "x" =~ /((?x))/; print "$+{x}\n" } # force Tie::Hash::NamedCapture 30 | 31 | IncSub::check 32 | -------------------------------------------------------------------------------- /tests/md5.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use File::Copy; 14 | 15 | use Devel::Cover::Test; 16 | 17 | my $t = "md5"; 18 | my $ft = "./tests/$t"; 19 | my $fg = "./tests/trivial"; 20 | 21 | my $run_test = sub { 22 | my $test = shift; 23 | 24 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 25 | open T, ">>$ft" or die "Cannot open $ft: $!"; 26 | print T "# blah blah\n"; 27 | close T or die "Cannot close $ft: $!"; 28 | $test->run_command($test->test_command); 29 | 30 | copy($fg, $ft) or die "Cannot copy $fg to $ft: $!"; 31 | $test->{test_parameters} .= " -merge 1"; 32 | $test->run_command($test->test_command); 33 | }; 34 | 35 | my $test = Devel::Cover::Test->new( 36 | $t, 37 | db_name => "complex_$t", 38 | run_test => $run_test, 39 | end => sub { unlink $ft }, 40 | delay_after_run => 0.50, 41 | ); 42 | 43 | $test->run_test; 44 | no warnings; 45 | $test # for create_gold 46 | -------------------------------------------------------------------------------- /tests/module1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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-2025, 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 | # https://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/module_ignore: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2025, 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 | # https://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/module_import: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | BEGIN { push @INC, "tests" } 11 | 12 | use Module_import; 13 | -------------------------------------------------------------------------------- /tests/module_relative: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $^O eq "cygwin" 11 | # __COVER__ skip_reason Busted on cygwin 12 | 13 | BEGIN { chdir "tests/random/dir" } 14 | use lib "../.."; 15 | use strict; 16 | use Module_import; 17 | -------------------------------------------------------------------------------- /tests/module_statements: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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 | 34 | package Module1; 35 | 36 | my $y = 7; 37 | $y++; 38 | 39 | sub _aa { 40 | $y++; 41 | die; 42 | die; 43 | } 44 | 45 | sub xx { 46 | $y++; 47 | die; 48 | } 49 | 50 | sub yy { 51 | $y++; 52 | } 53 | 54 | sub zz { 55 | my $x = shift; 56 | $x++; 57 | } 58 | 59 | 1 60 | 61 | __END__ 62 | 63 | =head2 yy 64 | 65 | yy 66 | 67 | =cut 68 | -------------------------------------------------------------------------------- /tests/moo_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test !(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/moose_basic: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://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/moose_cond: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/moose_constraint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://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/overload_bool: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2025, 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 | # https://pjcj.net 9 | 10 | package Foo; 11 | use overload 12 | '""' => sub { shift->render}, 13 | bool => sub { die "I was used as a bool and shouldn't be\n"; 1 }; 14 | 15 | sub render { 16 | "foo"; 17 | } 18 | 19 | my $foo = 1; 20 | bless {}, 'Foo' if $foo; 21 | 22 | my $boolobj = bless {}, 'Foo'; 23 | $boolobj //= 5; 24 | my $var; $var //= bless {}, "Foo"; 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /tests/overload_bool2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2014-2025, 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 | # https://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 | -------------------------------------------------------------------------------- /tests/overloaded: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2003-2025, 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 | # https://pjcj.net 9 | 10 | # Example stolen from overload documentation 11 | 12 | # __COVER__ changes s/^17 +3 +3/17 2 2/ 13 | # __COVER__ changes s/^(str +)3( tests/overloaded:17)/${1}2$2/ 14 | 15 | package two_face; 16 | 17 | sub new { my $p = shift; bless [@_], $p } 18 | use overload '""' => \&str, '0+' => \&num, fallback => 1; 19 | sub num {shift->[1]} 20 | sub str {shift->[0]} 21 | 22 | package main; 23 | 24 | my $seven = new two_face ("vii", 7); 25 | printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; 26 | print "seven contains `i'\n" if $seven =~ /i/; 27 | -------------------------------------------------------------------------------- /tests/padrange: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | my $a; 11 | my ($b, $c); 12 | my ($d); 13 | my @s; 14 | for (@s) {} 15 | -------------------------------------------------------------------------------- /tests/padrange2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | if (my @x = 'foo' =~ m/(.)/) { 7 | } else { 8 | } 9 | -------------------------------------------------------------------------------- /tests/pod: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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 | $x[shift]++; 25 | Module1::zz(0); 26 | } 27 | 28 | for (0 .. 10) { 29 | if (time) { 30 | xx(0); 31 | } else { 32 | $x[1]++; 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /tests/pod_nocp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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 | $x[shift]++; 25 | Module1::zz(0); 26 | } 27 | 28 | for (0 .. 10) { 29 | if (time) { 30 | xx(0); 31 | } else { 32 | $x[1]++; 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /tests/random/dir/file: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/pjcj/Devel--Cover/90c735b84b12a48d1b81eb44a95363750e35dd68/tests/random/dir/file -------------------------------------------------------------------------------- /tests/readonly: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2012-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test !(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 | -------------------------------------------------------------------------------- /tests/recursive_sub: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2022-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.016 11 | # __COVER__ skip_reason __SUB__ is available from 5.16 12 | 13 | use feature "current_sub"; 14 | 15 | sub recursive_func 16 | { 17 | my ($ref) = @_; 18 | return $ref unless ref $ref eq "ARRAY"; 19 | return __SUB__->($ref->[0]); 20 | } 21 | 22 | recursive_func([[[]]]); 23 | -------------------------------------------------------------------------------- /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/require: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | use lib -d "t" ? "." : ".."; 11 | use File::Spec; 12 | require File::Spec->catfile("tests", "E2.pm"); 13 | -------------------------------------------------------------------------------- /tests/signature: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2019-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ skip_test $] < 5.032 11 | # __COVER__ skip_reason Too fragile below 5.32 12 | 13 | use 5.20.0; 14 | use warnings; 15 | use experimental "signatures"; 16 | 17 | sub xx ($p, $q, $r, $s = 6, @t) { 18 | $p + $q + $r + $s + @t 19 | } 20 | 21 | my $x = xx(3, 4, 5); 22 | die unless $x == 18; 23 | -------------------------------------------------------------------------------- /tests/skip: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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/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/special_blocks: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/statement: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/subs_only: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2006-2025, 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 | # https://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/t0: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/t1: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/t2: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://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/taint: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2013-2025, 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 | # https://pjcj.net 9 | 10 | use strict; 11 | use warnings; 12 | use lib "tests"; 13 | 14 | use Taint; 15 | 16 | print "taint\n"; 17 | -------------------------------------------------------------------------------- /tests/trivial: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | my $x = 1; 11 | -------------------------------------------------------------------------------- /tests/uncoverable: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://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 | # uncoverable statement count:1,2 33 | b(); b(); 34 | 35 | # uncoverable statement count:1..4 36 | b(); b(); b(); b(); 37 | 38 | # uncoverable statement count:1,2,3..4,5..7,8,9,10..11,12 39 | b(); b(); b(); b(); b(); b(); b(); b(); b(); b(); b(); b(); 40 | } 41 | 42 | sub z { 43 | # uncoverable subroutine 44 | $y++; # uncoverable statement 45 | } 46 | 47 | # uncoverable branch false count:1 48 | # uncoverable branch true count:2 49 | # uncoverable branch false count:2 50 | # uncoverable condition left count:1,2 51 | # uncoverable condition right count:1..2 52 | # uncoverable condition true count:2 53 | # uncoverable condition false count:2 54 | if ($x > 0 && $y > 0) { 55 | $y++; 56 | } elsif ($x < 2 && $y < 0) { 57 | $y++; # uncoverable statement 58 | } else { 59 | $y++; # uncoverable statement 60 | } 61 | 62 | # uncoverable statement 63 | # uncoverable subroutine 64 | -------------------------------------------------------------------------------- /tests/uncoverable_error: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2023-2025, 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 | # https://pjcj.net 9 | 10 | sub usub { 11 | # uncoverable subroutine class:ignore_covered_err 12 | # uncoverable statement class:ignore_covered_err 13 | my $x = 1; 14 | } 15 | 16 | sub main { 17 | my $x = 1; 18 | # uncoverable branch false class:ignore_covered_err 19 | # uncoverable branch true 20 | if ($x > 1) { 21 | $x = 0; 22 | # uncoverable statement class:ignore_covered_err 23 | $x = 2; 24 | if ($x > 3) { 25 | $x = 4; 26 | } 27 | } 28 | 29 | my $y = 0; 30 | # uncoverable branch true 31 | # uncoverable condition left 32 | # uncoverable condition right class:ignore_covered_err 33 | # uncoverable condition false 34 | if ($x > 0 && $y > 0) { 35 | # uncoverable statement 36 | $y = 1; 37 | } 38 | 39 | while ($y < 4) { 40 | # uncoverable branch false 41 | # uncoverable condition left 42 | # uncoverable condition right 43 | if ($x > 0 && $y > 0) { 44 | $y = 4; 45 | } else { 46 | $y++; 47 | } 48 | } 49 | 50 | # uncoverable statement class:ignore_covered_err 51 | $x = 3; 52 | usub; 53 | } 54 | 55 | main 56 | -------------------------------------------------------------------------------- /tests/uncoverable_error_ignore: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2023-2025, 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 | # https://pjcj.net 9 | 10 | # __COVER__ cover_parameters -ignore_covered_err 11 | 12 | sub usub { 13 | # uncoverable subroutine 14 | # uncoverable statement 15 | my $x = 1; 16 | } 17 | 18 | sub main { 19 | my $x = 1; 20 | # uncoverable branch false 21 | # uncoverable branch true 22 | if ($x > 1) { 23 | $x = 0; 24 | # uncoverable statement 25 | $x = 2; 26 | if ($x > 3) { 27 | $x = 4; 28 | } 29 | } 30 | 31 | my $y = 0; 32 | # uncoverable branch true 33 | # uncoverable condition right 34 | if ($x > 0 && $y > 0) { 35 | # uncoverable statement 36 | $y = 1; 37 | } 38 | 39 | while ($y < 4) { 40 | # uncoverable branch false 41 | # uncoverable condition left 42 | # uncoverable condition right 43 | if ($x > 0 && $y > 0) { 44 | $y = 4; 45 | } else { 46 | $y++; 47 | } 48 | } 49 | 50 | # uncoverable statement 51 | $x = 3; 52 | usub; 53 | } 54 | 55 | main 56 | -------------------------------------------------------------------------------- /tests/xor_constant_fold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2004-2025, 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 | # https://pjcj.net 9 | 10 | 1 xor 0; 11 | -------------------------------------------------------------------------------- /utils/Devel/Cover/BuildUtils.pm: -------------------------------------------------------------------------------- 1 | # Copyright 2010-2025, 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 | # https://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 njobs 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 2>/dev/null`) }; 40 | $cpus || eval { ($cpus) = `sysctl hw.ncpu` =~ /(\d+)/ }; 41 | $cpus || 1 42 | } 43 | 44 | sub nice_cpus { 45 | $ENV{DEVEL_COVER_CPUS} || do { 46 | my $cpus = cpus; 47 | $cpus-- if $cpus > 3; 48 | $cpus-- if $cpus > 6; 49 | $cpus 50 | } 51 | } 52 | 53 | sub njobs { nice_cpus } 54 | 55 | sub prove_command { 56 | my $prove = find_prove or return; 57 | my $cpus = nice_cpus; 58 | "$prove -brj$cpus t" 59 | } 60 | 61 | __END__ 62 | 63 | =head1 NAME 64 | 65 | Devel::Cover::BuildUtils - Build utility functions for Devel::Cover 66 | 67 | =head1 SYNOPSIS 68 | 69 | use Devel::Cover::BuildUtils "find_prove"; 70 | 71 | =head1 DESCRIPTION 72 | 73 | Build utility functions for Devel::Cover. 74 | 75 | =head1 SEE ALSO 76 | 77 | Devel::Cover 78 | 79 | =head1 METHODS 80 | 81 | =head1 BUGS 82 | 83 | Huh? 84 | 85 | =head1 LICENCE 86 | 87 | Copyright 2001-2025, 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 | https://pjcj.net 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /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 "usage: $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 | -------------------------------------------------------------------------------- /utils/cpancover.nginx: -------------------------------------------------------------------------------- 1 | server { 2 | root /usr/share/nginx/www; 3 | index index.html index.html.gz; 4 | 5 | gzip on; 6 | gzip_static on; 7 | gzip_comp_level 9; 8 | gzip_min_length 1400; 9 | gzip_types text/plain text/css image/png image/gif image/jpeg application/x-javascript text/xml application/xml application/xml+rss text/javascript; 10 | gzip_vary on; 11 | gzip_http_version 1.1; 12 | gzip_disable "MSIE [1-6]\.(?!.*SV1)"; 13 | 14 | server_name localhost; 15 | 16 | location / { 17 | rewrite ^/$ /latest/index.html permanent; 18 | } 19 | 20 | error_page 404 /404.html; 21 | } 22 | -------------------------------------------------------------------------------- /utils/create_all_gold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2011-2025, 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 | # https://pjcj.net 9 | 10 | require 5.12.0; 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 | -------------------------------------------------------------------------------- /utils/create_gold: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2002-2025, 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 | # https://pjcj.net 9 | 10 | require 5.12.0; 11 | 12 | use strict; 13 | use warnings; 14 | 15 | # VERSION 16 | 17 | use blib; 18 | 19 | use Config; 20 | die "useithreads true, exiting" 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|swp)$/; 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 | -------------------------------------------------------------------------------- /utils/mail_contributors: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # Copyright 2013-2025, 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 | # https://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 ')->to($email) 64 | ->subject("Devel::Cover Authors File")->text_body($body)->send_or_die; 65 | }; 66 | if ($@) { 67 | say "Failed to send mail <$line>\n$@" 68 | } else { 69 | say "Sent mail <$line>" 70 | } 71 | } 72 | } 73 | 74 | main 75 | -------------------------------------------------------------------------------- /utils/makeh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Copyright 2001-2025, 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 | # https://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/ .. /^--------/ 22 | and $t > -1 23 | and length > $t; 24 | print; 25 | } 26 | } 27 | }; 28 | 29 | sub main { 30 | my ($command) = @ARGV; 31 | die "No such command: $command" unless $Command->{$command}; 32 | $Command->{$command}->(@ARGV) 33 | } 34 | 35 | main 36 | -------------------------------------------------------------------------------- /utils/queue.conf: -------------------------------------------------------------------------------- 1 | { results_dir => "/cover/staging_dev" } 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /utils/setup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # . ./utils/setup 4 | 5 | # shellcheck disable=SC3037 6 | tidy() { echo -n "$1" | perl -naF: -e'print join ":", grep !$s{$_}++&&-e, @F'; } 7 | dc_home=$PWD 8 | PATH=$(tidy "$dc_home/utils:$PATH") 9 | export PATH 10 | 11 | if [ -n "$ZSH_VERSION" ]; then 12 | # shellcheck disable=SC2207,SC3030 13 | _dc() { reply=($(utils/dc options)); } 14 | # shellcheck disable=SC2207,SC3030,SC2034 15 | _build() { reply=($(docker/BUILD options)); } 16 | compctl -K _dc dc 17 | compctl -K _build BUILD 18 | fi 19 | -------------------------------------------------------------------------------- /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 | --------------------------------------------------------------------------------