diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 00000000..f079ee37 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,14 @@ +root = true + +[*] +charset = utf-8 +end_of_line = lf +indent_style = space +indent_size = 2 +tab_width = 2 +insert_final_newline = true +max_line_length = 80 +trim_trailing_whitespace = true + +[Makefile] +indent_style = tab diff --git a/.hadolint.yaml b/.hadolint.yaml new file mode 100644 index 00000000..d3272ea1 --- /dev/null +++ b/.hadolint.yaml @@ -0,0 +1,2 @@ +--- +failure-threshold: style diff --git a/.markdownlint.yaml b/.markdownlint.yaml new file mode 100644 index 00000000..000ec784 --- /dev/null +++ b/.markdownlint.yaml @@ -0,0 +1,4 @@ +--- +default: true +MD013: { stern: true } +MD024: { siblings_only: true } diff --git a/.mdformat.toml b/.mdformat.toml new file mode 100644 index 00000000..01b2fb06 --- /dev/null +++ b/.mdformat.toml @@ -0,0 +1 @@ +number = true diff --git a/.perlcriticrc b/.perlcriticrc new file mode 100644 index 00000000..0bd2c7ef --- /dev/null +++ b/.perlcriticrc @@ -0,0 +1,1606 @@ +# Globals +severity = 2 +# force = 0 +# only = 0 +allow-unsafe = 1 +# profile-strictness = warn +# color = 0 +# pager = +# top = 0 +verbose = 8 +# include = +# exclude = +# single-policy = +# theme = +color-severity-highest = red +color-severity-high = magenta +color-severity-medium = bold magenta +color-severity-low = blue +color-severity-lowest = cyan +# program-extensions = + +# Use `any' from `List::Util', `List::SomeUtils', or `List::MoreUtils' instead of `grep' in boolean context. +[BuiltinFunctions::ProhibitBooleanGrep] +# set_themes = certrec core pbp performance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Map blocks should have a single statement. +[BuiltinFunctions::ProhibitComplexMappings] +# set_themes = complexity core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum number of statements to allow within a map block. +# Minimum value 1. No maximum. +max_statements = 5 + + +# Use 4-argument `substr' instead of writing `substr($foo, 2, 6) = $bar'. +[BuiltinFunctions::ProhibitLvalueSubstr] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Forbid $b before $a in sort blocks. +[BuiltinFunctions::ProhibitReverseSortBlock] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + + +# Prohibit `\shift' in code +[BuiltinFunctions::ProhibitShiftRef] +# set_themes = bugs core tests +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Use Time::HiRes instead of something like `select(undef, undef, undef, .05)'. +[-BuiltinFunctions::ProhibitSleepViaSelect] +# set_themes = bugs core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Write `eval { my $foo; bar($foo) }' instead of `eval "my $foo; bar($foo);"'. +[BuiltinFunctions::ProhibitStringyEval] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + +# Allow eval of "use" and "require" strings. +allow_includes = 1 + + +# Write `split /-/, $string' instead of `split '-', $string'. +[BuiltinFunctions::ProhibitStringySplit] +# set_themes = certrule core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Write `eval { $foo->can($name) }' instead of `UNIVERSAL::can($foo, $name)'. +[BuiltinFunctions::ProhibitUniversalCan] +# set_themes = certrule core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `eval { $foo->isa($pkg) }' instead of `UNIVERSAL::isa($foo, $pkg)'. +[BuiltinFunctions::ProhibitUniversalIsa] +# set_themes = certrule core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Don't pass $_ to built-in functions that assume it, or to most filetest operators. +[BuiltinFunctions::ProhibitUselessTopic] +# set_themes = core +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't use `grep' in void contexts. +[BuiltinFunctions::ProhibitVoidGrep] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Don't use `map' in void contexts. +[BuiltinFunctions::ProhibitVoidMap] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `grep { /$pattern/ } @list' instead of `grep /$pattern/, @list'. +[-BuiltinFunctions::RequireBlockGrep] +# set_themes = bugs core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `map { /$pattern/ } @list' instead of `map /$pattern/, @list'. +[-BuiltinFunctions::RequireBlockMap] +# set_themes = bugs core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Use `glob q{*}' instead of <*>. +[-BuiltinFunctions::RequireGlobFunction] +# set_themes = bugs core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Sort blocks should have a single statement. +[-BuiltinFunctions::RequireSimpleSortBlock] +# set_themes = complexity core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# AUTOLOAD methods should be avoided. +[-ClassHierarchies::ProhibitAutoloading] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Employ `use parent' instead of `@ISA'. +[ClassHierarchies::ProhibitExplicitISA] +# set_themes = certrec core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `bless {}, $class;' instead of just `bless {};'. +[ClassHierarchies::ProhibitOneArgBless] +# set_themes = bugs core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Use spaces instead of tabs. +[CodeLayout::ProhibitHardTabs] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Allow hard tabs before first non-whitespace character. +# allow_leading_tabs = 1 + + +# Write `open $handle, $path' instead of `open($handle, $path)'. +[CodeLayout::ProhibitParensWithBuiltins] +# set_themes = core cosmetic pbp +# add_themes = +severity = 2 +# maximum_violations_per_document = no_limit + + +# Write `qw(foo bar baz)' instead of `('foo', 'bar', 'baz')'. +[CodeLayout::ProhibitQuotedWordLists] +# set_themes = core cosmetic +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The minimum number of words in a list that will be complained about. +# Minimum value 1. No maximum. +# min_elements = 2 + +# Complain even if there are non-word characters in the values. +# strict = 0 + + +# Don't use whitespace at the end of lines. +[CodeLayout::ProhibitTrailingWhitespace] +# set_themes = core maintenance +# add_themes = +severity = 2 +# maximum_violations_per_document = no_limit + + +# Use the same newline through the source. +[CodeLayout::RequireConsistentNewlines] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Must run code through perltidy. +[CodeLayout::RequireTidyCode] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# The Perl::Tidy configuration file to use, if any. +# perltidyrc = + + +# Put a comma at the end of every multi-line list declaration, including the last one. +[CodeLayout::RequireTrailingCommas] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + + +# We would like to use this policy for simple loops but for loops have their +# place in more complicated cases so we'll turn this off. +# Write `for(0..20)' instead of `for($i=0; $i<=20; $i++)'. +[-ControlStructures::ProhibitCStyleForLoops] +# set_themes = core maintenance pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't write long "if-elsif-elsif-elsif-elsif...else" chains. +[ControlStructures::ProhibitCascadingIfElse] +# set_themes = complexity core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum number of alternatives that will be allowed. +# Minimum value 1. No maximum. +max_elsif = 10 + + +# Don't write deeply nested loops and conditionals. +[ControlStructures::ProhibitDeepNests] +# set_themes = complexity core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum number of nested constructs to allow. +# Minimum value 1. No maximum. +# max_nests = 5 + + +# Don't use labels that are the same as the special block names. +[ControlStructures::ProhibitLabelsWithSpecialBlockNames] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Don't modify `$_' in list functions. +[ControlStructures::ProhibitMutatingListFunctions] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + +# The base set of functions to check. +# list_funcs = map grep List::Util::first List::MoreUtils::any List::SomeUtils::any List::MoreUtils::all List::SomeUtils::all List::MoreUtils::none List::SomeUtils::none List::MoreUtils::notall List::SomeUtils::notall List::MoreUtils::true List::SomeUtils::true List::MoreUtils::false List::SomeUtils::false List::MoreUtils::firstidx List::SomeUtils::firstidx List::MoreUtils::first_index List::SomeUtils::first_index List::MoreUtils::lastidx List::SomeUtils::lastidx List::MoreUtils::last_index List::SomeUtils::last_index List::MoreUtils::insert_after List::SomeUtils::insert_after List::MoreUtils::insert_after_string List::SomeUtils::insert_after_string + +# The set of functions to check, in addition to those given in list_funcs. +# add_list_funcs = + + +# Don't use operators like `not', `!~', and `le' within `until' and `unless'. +[-ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `if($condition){ do_something() }' instead of `do_something() if $condition'. +[-ControlStructures::ProhibitPostfixControls] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The permitted postfix controls. +# Valid values: for, foreach, if, unless, until, when, while. +# allow = + +# The exempt flow control functions. +# flowcontrol = carp cluck confess croak die exit goto warn + + +# Write `if(! $condition)' instead of `unless($condition)'. +[-ControlStructures::ProhibitUnlessBlocks] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't write code after an unconditional `die, exit, or next'. +[ControlStructures::ProhibitUnreachableCode] +# set_themes = bugs certrec core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `while(! $condition)' instead of `until($condition)'. +[-ControlStructures::ProhibitUntilBlocks] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Never use `...' in production code. +[ControlStructures::ProhibitYadaOperator] +# set_themes = core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Check your spelling. +[Documentation::PodSpelling] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# The command to invoke to check spelling. +# spell_command = aspell list + +# The words to not consider as misspelled. +# stop_words = + +# A file containing words to not consider as misspelled. +# stop_words_file = + + +# The `=head1 NAME' section should match the package. +[Documentation::RequirePackageMatchesPodName] +# set_themes = core cosmetic +# add_themes = +severity = 3 +# maximum_violations_per_document = no_limit + + +# All POD should be after `__END__'. +[Documentation::RequirePodAtEnd] +# set_themes = core cosmetic pbp +# add_themes = +severity = 3 +# maximum_violations_per_document = no_limit + + +# Organize your POD into the customary sections. +[Documentation::RequirePodSections] +# set_themes = core maintenance pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The sections to require for modules (separated by qr/\s* [|] \s*/xms). +# We'd like at least one of ATTRIBUTES | LAZY-ATTRIBUTES | METHODS | SUBROUTINES +# but can't specify that. +lib_sections = NAME | SYNOPSIS | DESCRIPTION + +# The sections to require for programs (separated by qr/\s* [|] \s*/xms). +script_sections = NAME | SYNOPSIS | DESCRIPTION + +# The origin of sections to use. +# Valid values: book, book_first_edition, module_starter_pbp, module_starter_pbp_0_0_3. +# source = book_first_edition + +# The spelling of sections to use. +# Valid values: en_AU, en_US. +# language = + + +# Use functions from Carp instead of `warn' or `die'. +[-ErrorHandling::RequireCarping] +# set_themes = certrule core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Don't complain about die or warn if the message ends in a newline. +# allow_messages_ending_with_newlines = 1 + +# Don't complain about die or warn in main::, unless in a subroutine. +# allow_in_main_unless_in_subroutine = 0 + + +# You can't depend upon the value of `$@'/`$EVAL_ERROR' to tell whether an `eval' failed. +[ErrorHandling::RequireCheckingReturnValueOfEval] +# set_themes = bugs core +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Discourage stuff like `@files = `ls $directory`'. +[InputOutput::ProhibitBacktickOperators] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Allow backticks everywhere except in void contexts. +only_in_void_context = 1 + + +# Write `opendir my $dh, $dirname;' instead of `opendir DH, $dirname;'. +[InputOutput::ProhibitBarewordDirHandles] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Write `open my $fh, q{<}, $filename;' instead of `open FH, q{<}, $filename;'. +[InputOutput::ProhibitBarewordFileHandles] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Use "<>" or "" or a prompting module instead of "". +[InputOutput::ProhibitExplicitStdin] +# set_themes = core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Use prompt() instead of -t. +[-InputOutput::ProhibitInteractiveTest] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Use `local $/ = undef' or Path::Tiny instead of joined readline. +[InputOutput::ProhibitJoinedReadline] +# set_themes = core pbp performance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Never write `select($fh)'. +[InputOutput::ProhibitOneArgSelect] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `while( $line = <> ){...}' instead of `for(<>){...}'. +[InputOutput::ProhibitReadlineInForLoop] +# set_themes = bugs core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `open $fh, q{<}, $filename;' instead of `open $fh, "<$filename";'. +[InputOutput::ProhibitTwoArgOpen] +# set_themes = bugs certrule core pbp security +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Write `print {$FH} $foo, $bar;' instead of `print $FH $foo, $bar;'. +[-InputOutput::RequireBracedFileHandleWithPrint] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + + +# Close filehandles as soon as possible after opening them. +[-InputOutput::RequireBriefOpen] +# set_themes = core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The maximum number of lines between an open() and a close(). +# Minimum value 1. No maximum. + + +# Write `my $error = close $fh;' instead of `close $fh;'. +[InputOutput::RequireCheckedClose] +# set_themes = certrule core maintenance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# Modules which export autodie. +# autodie_modules = autodie + + +# Write `my $error = open $fh, $mode, $filename;' instead of `open $fh, $mode, $filename;'. +[InputOutput::RequireCheckedOpen] +# set_themes = certrule core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Modules which export autodie. +# autodie_modules = autodie + + +# Return value of flagged function ignored. +[InputOutput::RequireCheckedSyscalls] +# set_themes = certrule core maintenance +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# The set of functions to require checking the return value of. +# functions = open close print say + +# The set of functions to not require checking the return value of. +# exclude_functions = + +# Modules which export autodie. +# autodie_modules = autodie + + +# Write `open $fh, q{<:encoding(UTF-8)}, $filename;' instead of `open $fh, q{<:utf8}, $filename;'. +[InputOutput::RequireEncodingWithUTF8Layer] +# set_themes = bugs core security +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Do not use `format'. +[Miscellanea::ProhibitFormats] +# set_themes = certrule core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Do not use `tie'. +[Miscellanea::ProhibitTies] +# set_themes = core maintenance pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Forbid a bare `## no critic' +[Miscellanea::ProhibitUnrestrictedNoCritic] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Remove ineffective "## no critic" annotations. +[Miscellanea::ProhibitUselessNoCritic] +# set_themes = core maintenance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Export symbols via `@EXPORT_OK' or `%EXPORT_TAGS' instead of `@EXPORT'. +[Modules::ProhibitAutomaticExportation] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Avoid putting conditional logic around compile-time includes. +[Modules::ProhibitConditionalUseStatements] +# set_themes = bugs core +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Ban modules that aren't blessed by your shop. +[Modules::ProhibitEvilModules] +# set_themes = bugs certrule core +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + +# The names of or patterns for modules to forbid. +# modules = Class::ISA {Found use of Class::ISA. This module is deprecated by the Perl 5 Porters.} Pod::Plainer {Found use of Pod::Plainer. This module is deprecated by the Perl 5 Porters.} Shell {Found use of Shell. This module is deprecated by the Perl 5 Porters.} Switch {Found use of Switch. This module is deprecated by the Perl 5 Porters.} + +# A file containing names of or patterns for modules to forbid. +# modules_file = + + +# Minimize complexity in code that is outside of subroutines. +[Modules::ProhibitExcessMainComplexity] +# set_themes = complexity core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum complexity score allowed. +# Minimum value 1. No maximum. +# max_mccabe = 20 +# Allow for a little code in "around" subs and similar. +max_mccabe = 3 + + +# Put packages (especially subclasses) in separate files. +# There can be good reasons to do this but since there is no additional config +# we'll turn this off. +[-Modules::ProhibitMultiplePackages] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `require Module' instead of `require 'Module.pm''. +[Modules::RequireBarewordIncludes] +# set_themes = core portability +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# End each module with an explicitly `1;' instead of some funky expression. +[-Modules::RequireEndWithOne] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Always make the `package' explicit. +[Modules::RequireExplicitPackage] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = 1 + +# Don't require programs to contain a package statement. +# exempt_scripts = 1 + +# Allow the specified modules to be imported outside a package. +# allow_import_of = + + +# Package declaration must match filename. +[Modules::RequireFilenameMatchesPackage] +# set_themes = bugs core +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# `use English' must be passed a `-no_match_vars' argument. +[Modules::RequireNoMatchVarsWithUseEnglish] +# set_themes = core performance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Give every module a `$VERSION' number. +[-Modules::RequireVersionVar] +# set_themes = core pbp readability +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Use DEMOLISH instead of DESTROY +[Moose::ProhibitDESTROYMethod] +# set_themes = bugs moose +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The additional modules to treat as equivalent to "Moose", "Moose::Role", or "MooseX::Role::Parameterized". +# Values that are always included: Moose, Moose::Role, MooseX::Role::Parameterized. +# equivalent_modules = +equivalent_modules = Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base::Moose Perceptyx::Base::Moose::Role + + +# Avoid lazy_build +[-Moose::ProhibitLazyBuild] +# set_themes = bugs moose +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The additional modules to treat as equivalent to "Moose", "Moose::Role", "MooseX::Role::Parameterized", or "MooseX::Singleton". +# Values that are always included: Moose, Moose::Role, MooseX::Role::Parameterized, MooseX::Singleton. +# equivalent_modules = Moose Moose::Role MooseX::Role::Parameterized MooseX::Singleton +equivalent_modules = Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base::Moose Perceptyx::Base::Moose::Role + + +# Require role composition +[Moose::ProhibitMultipleWiths] +# set_themes = bugs moose roles +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The additional modules to treat as equivalent to "Moose", "Moose::Role", or "MooseX::Role::Parameterized". +# Values that are always included: Moose, Moose::Role, MooseX::Role::Parameterized. +# equivalent_modules = Moose Moose::Role MooseX::Role::Parameterized +equivalent_modules = Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base::Moose Perceptyx::Base::Moose::Role + + +# Don't override Moose's standard constructors. +[Moose::ProhibitNewMethod] +# set_themes = bugs moose +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The additional modules to treat as equivalent to "Moose", "Moose::Role", or "MooseX::Role::Parameterized". +# Values that are always included: Moose, Moose::Role, MooseX::Role::Parameterized. +# equivalent_modules = Moose Moose::Role MooseX::Role::Parameterized +equivalent_modules = Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base::Moose Perceptyx::Base::Moose::Role + + +# Require removing implementation details from you packages. +[Moose::RequireCleanNamespace] +# set_themes = maintenance moose +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The modules that need to be unimported. +# modules = Moose Moose::Role Moose::Util::TypeConstraints MooseX::Role::Parameterized + +# Modules that clean imports. +# cleaners = namespace::autoclean + + +# Ensure that you've made your Moose code fast +[Moose::RequireMakeImmutable] +# set_themes = moose performance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The additional modules to treat as equivalent to "Moose". +# Values that are always included: Moose. +# equivalent_modules = Moose +equivalent_modules = Repobase::Base::Moose Perceptyx::Base::Moose + + +# Distinguish different program components by case. +[NamingConventions::Capitalization] +# set_themes = core cosmetic pbp +# add_themes = +severity = 2 +# maximum_violations_per_document = no_limit + +# How package name components should be capitalized. Valid values are :single_case, :all_lower, :all_upper:, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +packages = via|[A-Z][a-z0-9_]* + +# Package names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# package_exemptions = main + +# How subroutine names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +subroutines = :all_lower + +# Subroutine names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +subroutine_exemptions = AUTOLOAD BUILD BUILDARGS CLEAR CLOSE DELETE DEMOLISH DESTROY EXISTS EXTEND FETCH FETCHSIZE FIRSTKEY GETC NEXTKEY POP PRINT PRINTF PUSH READ READLINE SCALAR SHIFT SPLICE STORE STORESIZE TIEARRAY TIEHANDLE TIEHASH TIESCALAR UNSHIFT UNTIE PUSHED OPEN WRITE CXT LOG CFG TRC + +# How local lexical variables names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +local_lexical_variables = :all_lower + +# Local lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# local_lexical_variable_exemptions = + +# How lexical variables that are scoped to a subset of subroutines, should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +scoped_lexical_variables = :all_lower + +# Names for variables in anonymous blocks that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# scoped_lexical_variable_exemptions = + +# How lexical variables at the file level should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +file_lexical_variables = [A-Z][a-z0-9_]* + +# File-scope lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# file_lexical_variable_exemptions = + +# How global (package) variables should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +global_variables = [A-Z][a-z0-9_]* + +# Global variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +global_variable_exemptions = VERSION ISA EXPORT(?:_OK)? EXPORT_TAGS AUTOLOAD ENV SIG + +# How constant names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +# constants = :all_upper + +# Constant names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# constant_exemptions = + +# How labels should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex. +# labels = :all_upper + +# Labels that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z. +# label_exemptions = + + +# Don't use vague variable or subroutine names like 'last' or 'record'. +[NamingConventions::ProhibitAmbiguousNames] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The variable names that are not to be allowed. +forbid = abstract bases contract left no record right second + + +# Prohibit indirect object call syntax. +[Objects::ProhibitIndirectSyntax] +# set_themes = certrule core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Indirect method syntax is forbidden for these methods. +# Values that are always included: new. +# forbid = + + +# Write `@{ $array_ref }' instead of `@$array_ref'. +[-References::ProhibitDoubleSigils] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Capture variable used outside conditional. +[RegularExpressions::ProhibitCaptureWithoutTest] +# set_themes = certrule core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Names of ways to generate exceptions. +# Values that are always included: confess, croak, die. +# exception_source = + + +# Split long regexps into smaller `qr//' chunks. +[-RegularExpressions::ProhibitComplexRegexes] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum number of characters to allow in a regular expression. +# Minimum value 1. No maximum. +# max_characters = 60 + + +# Use named character classes instead of explicit character lists. +[RegularExpressions::ProhibitEnumeratedClasses] +# set_themes = core cosmetic pbp unicode +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + + +# Use character classes for literal meta-characters instead of escapes. +[RegularExpressions::ProhibitEscapedMetacharacters] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + + +# Use `eq' or hash instead of fixed-pattern regexps. +[RegularExpressions::ProhibitFixedStringMatches] +# set_themes = core pbp performance +# add_themes = +severity = 1 +# maximum_violations_per_document = no_limit + + +# Use `[abc]' instead of `a|b|c'. +[RegularExpressions::ProhibitSingleCharAlternation] +# set_themes = core pbp performance +# add_themes = +# severity = 1 +severity = 2 +# maximum_violations_per_document = no_limit + + +# Only use a capturing group if you plan to use the captured value. +[RegularExpressions::ProhibitUnusedCapture] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Use only `//' or `{}' to delimit regexps. +[-RegularExpressions::ProhibitUnusualDelimiters] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# In addition to allowing '{}', allow '()', '[]', and '{}'. +# allow_all_brackets = + + +# Don't use $_ to match against regexes. +[RegularExpressions::ProhibitUselessTopic] +# set_themes = core +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Use `{' and `}' to delimit multi-line regexps. +[-RegularExpressions::RequireBracesForMultiline] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# In addition to allowing '{}', allow '()', '[]', and '{}'. +# allow_all_brackets = + + +# Always use the `/s' modifier with regular expressions. +[-RegularExpressions::RequireDotMatchAnything] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Always use the `/x' modifier with regular expressions. +[-RegularExpressions::RequireExtendedFormatting] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The number of characters that a regular expression must contain before this policy will complain. +# Minimum value 0. No maximum. +# minimum_regex_length_to_complain_about = 0 + +# Should regexes that only contain whitespace and word characters be complained about?. +# strict = 0 + + +# Always use the `/m' modifier with regular expressions. +[-RegularExpressions::RequireLineBoundaryMatching] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't call functions with a leading ampersand sigil. +[Subroutines::ProhibitAmpersandSigils] +# set_themes = core maintenance pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't declare your own `open' function. +# When used as method names this is fine. +[-Subroutines::ProhibitBuiltinHomonyms] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Subroutines matching the name regex to allow under this policy. +# allow = print + + +# Minimize complexity by factoring code into smaller subroutines. +[Subroutines::ProhibitExcessComplexity] +# set_themes = complexity core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum complexity score allowed. +# Minimum value 1. No maximum. +# max_mccabe = 20 + + +# Return failure with bare `return' instead of `return undef'. +[-Subroutines::ProhibitExplicitReturnUndef] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Too many arguments. +[Subroutines::ProhibitManyArgs] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The maximum number of arguments to allow a subroutine to have. +# Minimum value 1. No maximum. +# NOTE: underscores create separate arguments: +# https://github.com/Perl-Critic/Perl-Critic/issues/1027 +max_arguments = 5 + +# Don't count $self or $class first argument. +skip_object = 1 + + +# `sub never { sub correct {} }'. +[Subroutines::ProhibitNestedSubs] +# set_themes = bugs core +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Behavior of `sort' is not defined if called in scalar context. +[Subroutines::ProhibitReturnSort] +# set_themes = bugs certrule core +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Don't write `sub my_function (@@) {}'. +[-Subroutines::ProhibitSubroutinePrototypes] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Prevent unused private subroutines. +[Subroutines::ProhibitUnusedPrivateSubroutines] +# set_themes = certrec core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Pattern that determines what a private subroutine is. +# private_name_regex = \b_\w+\b + +# Subroutines matching the private name regex to allow under this policy. +# allow = + +# Modules that, if used within a file, will cause the policy to be disabled for this file. +# skip_when_using = + +# Pattern defining private subroutine names that are always allowed. +allow_name_regex = ^(?:_build_\w+|_data_printer)$ + + +# Prevent access to private subs in other packages. +[Subroutines::ProtectPrivateSubs] +# set_themes = certrule core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Pattern that determines what a private subroutine is. +# private_name_regex = \b_\w+\b + +# Subroutines matching the private name regex to allow under this policy. +# Values that are always included: POSIX::_PC_CHOWN_RESTRICTED, POSIX::_PC_LINK_MAX, POSIX::_PC_MAX_CANON, POSIX::_PC_MAX_INPUT, POSIX::_PC_NAME_MAX, POSIX::_PC_NO_TRUNC, POSIX::_PC_PATH_MAX, POSIX::_PC_PIPE_BUF, POSIX::_PC_VDISABLE, POSIX::_POSIX_ARG_MAX, POSIX::_POSIX_CHILD_MAX, POSIX::_POSIX_CHOWN_RESTRICTED, POSIX::_POSIX_JOB_CONTROL, POSIX::_POSIX_LINK_MAX, POSIX::_POSIX_MAX_CANON, POSIX::_POSIX_MAX_INPUT, POSIX::_POSIX_NAME_MAX, POSIX::_POSIX_NGROUPS_MAX, POSIX::_POSIX_NO_TRUNC, POSIX::_POSIX_OPEN_MAX, POSIX::_POSIX_PATH_MAX, POSIX::_POSIX_PIPE_BUF, POSIX::_POSIX_SAVED_IDS, POSIX::_POSIX_SSIZE_MAX, POSIX::_POSIX_STREAM_MAX, POSIX::_POSIX_TZNAME_MAX, POSIX::_POSIX_VDISABLE, POSIX::_POSIX_VERSION, POSIX::_SC_ARG_MAX, POSIX::_SC_CHILD_MAX, POSIX::_SC_CLK_TCK, POSIX::_SC_JOB_CONTROL, POSIX::_SC_NGROUPS_MAX, POSIX::_SC_OPEN_MAX, POSIX::_SC_PAGESIZE, POSIX::_SC_SAVED_IDS, POSIX::_SC_STREAM_MAX, POSIX::_SC_TZNAME_MAX, POSIX::_SC_VERSION, POSIX::_exit. +# allow = + + +# Always unpack `@_' first. +[Subroutines::RequireArgUnpacking] +# set_themes = core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The number of statements to allow without unpacking. +# Minimum value 0. No maximum. +# short_subroutine_statements = 0 + +# Should unpacking from array slices and elements be allowed?. +# allow_subscripts = 0 + +# Allow the usual delegation idiom to these namespaces/subroutines. +# Values that are always included: NEXT::, SUPER::. +# allow_delegation_to = + +# Allow unpacking by a closure. +# allow_closures = 0 + + +# End every path through a subroutine with an explicit `return' statement. +[-Subroutines::RequireFinalReturn] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The additional subroutines to treat as terminal. +# Values that are always included: ..., Carp::confess, Carp::croak, confess, croak, die, exec, exit, throw. +# terminal_funcs = + +# The additional methods to treat as terminal. +# Values that are always included: . +# terminal_methods = + + +# Prohibit various flavors of `no strict'. +[TestingAndDebugging::ProhibitNoStrict] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + +# Allow vars, subs, and/or refs. +allow = refs + + +# Prohibit various flavors of `no warnings'. +[TestingAndDebugging::ProhibitNoWarnings] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Permitted warning categories. +# allow = + +# Allow "no warnings" if it restricts the kinds of warnings that are turned off. +allow_with_category_restriction = 1 + + +# Don't turn off strict for large blocks of code. +[TestingAndDebugging::ProhibitProlongedStrictureOverride] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# The maximum number of statements in a no strict block. +# Minimum value 1. No maximum. +# If we're doing this it's probably deliberate and might be for quite a few +# subs. +statements = 10 + + +# Tests should all have labels. +[TestingAndDebugging::RequireTestLabels] +# set_themes = core maintenance tests +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The additional modules to require labels for. +# Values that are always included: Test::More. +# modules = + + +# Always `use strict'. +[TestingAndDebugging::RequireUseStrict] +# set_themes = bugs certrec certrule core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = 1 + +# The additional modules to treat as equivalent to "strict". +# Values that are always included: Any::Moose, Dancer, Dancer2, Mo, Modern::Perl, Mojo::Base, Mojolicious::Lite, Moo, Moo::Role, Moos, Moose, Moose::Exporter, Moose::Role, Moose::Util::TypeConstraints, MooseX::MethodAttributes::Role, MooseX::NonMoose, MooseX::Role::Parameterized, MooseX::Singleton, Mouse, Mouse::Exporter, Mouse::Role, Mouse::Util, Mouse::Util::TypeConstraints, Mousse, Object::Simple, Role::Tiny, Test::Class::Moose, Test::Spec, sane, strict, strictures. +equivalent_modules = Repobase::Base Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base Perceptyx::Base::Moose Perceptyx::Base::Moose::Role Test::Perceptyx::Base + + +# Always `use warnings'. +[TestingAndDebugging::RequireUseWarnings] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = 1 + +# The additional modules to treat as equivalent to "warnings". +# Values that are always included: Any::Moose, Dancer, Dancer2, Mo, Modern::Perl, Mojo::Base, Mojolicious::Lite, Moo, Moo::Role, Moos, Moose, Moose::Exporter, Moose::Role, Moose::Util::TypeConstraints, MooseX::MethodAttributes::Role, MooseX::NonMoose, MooseX::Role::Parameterized, MooseX::Singleton, Mouse, Mouse::Exporter, Mouse::Role, Mouse::Util, Mouse::Util::TypeConstraints, Mousse, Object::Simple, Role::Tiny, Test::Class::Moose, Test::Spec, sane, strictures, warnings. +equivalent_modules = Repobase::Base Repobase::Base::Moose Repobase::Base::Moose::Role Perceptyx::Base Perceptyx::Base::Moose Perceptyx::Base::Moose::Role Test::Perceptyx::Base + + +# Don't use the comma operator as a statement separator. +[-ValuesAndExpressions::ProhibitCommaSeparatedStatements] +# set_themes = bugs certrule core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Allow map and grep blocks to return lists. +# allow_last_statement_to_be_comma_separated_in_map_and_grep = 0 + + +# Prohibit version values from outside the module. +[ValuesAndExpressions::ProhibitComplexVersion] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# Make "use version; our $VERSION = qv('1.2.3');" a violation of this policy. +# forbid_use_version = 0 + + +# Don't `use constant FOO => 15'. +[ValuesAndExpressions::ProhibitConstantPragma] +# set_themes = bugs core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Write `q{}' instead of `'''. +[-ValuesAndExpressions::ProhibitEmptyQuotes] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Write `"\N{DELETE}"' instead of `"\x7F"', etc. +[-ValuesAndExpressions::ProhibitEscapedCharacters] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Use concatenation or HEREDOCs instead of literal line breaks in strings. +[ValuesAndExpressions::ProhibitImplicitNewlines] +# set_themes = core cosmetic pbp +# add_themes = +severity = 1 +# maximum_violations_per_document = no_limit + + +# Always use single quotes for literal strings. +[-ValuesAndExpressions::ProhibitInterpolationOfLiterals] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# Kinds of delimiters to permit, e.g. "qq{", "qq(", "qq[", "qq/". +# allow = + +# If the string contains ' characters, allow "" to quote it. +# allow_if_string_contains_single_quote = 0 + + +# Write `oct(755)' instead of `0755'. +[-ValuesAndExpressions::ProhibitLeadingZeros] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + +# Don't allow any leading zeros at all. Otherwise builtins that deal with Unix permissions, e.g. chmod, don't get flagged. +# strict = 0 + + +# Long chains of method calls indicate tightly coupled code. +[ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] +# set_themes = core maintenance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The number of chained calls to allow. +# Minimum value 1. No maximum. +# max_chain_length = 3 + + +# Don't use values that don't explain themselves. +[ValuesAndExpressions::ProhibitMagicNumbers] +# set_themes = certrec core maintenance +# add_themes = +severity = 1 +# maximum_violations_per_document = 10 + +# Individual and ranges of values to allow, and/or "all_integers". +# allowed_values = 0 1 2 + +# Kind of literals to allow. +# Valid values: Binary, Exp, Float, Hex, Octal. +# allowed_types = Float + +# Should anything to the right of a "=>" be allowed?. +# allow_to_the_right_of_a_fat_comma = 1 + +# Names of subroutines that create constants. +# Values that are always included: Readonly, Readonly::Array, Readonly::Hash, Readonly::Scalar, const. +# constant_creator_subroutines = + + +# Don't mix numeric operators with string operands, or vice-versa. +[ValuesAndExpressions::ProhibitMismatchedOperators] +# set_themes = bugs certrule core +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write ` !$foo && $bar || $baz ' instead of ` not $foo && $bar or $baz'. +[ValuesAndExpressions::ProhibitMixedBooleanOperators] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Use `q{}' or `qq{}' instead of quotes for awkward-looking strings. +[-ValuesAndExpressions::ProhibitNoisyQuotes] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Don't use quotes (`'', `"', ``') as delimiters for the quote-like operators. +[ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The operators to allow single-quotes as delimiters for. +# Valid values: m, q, qq, qr, qw, qx, s, tr, y. +# single_quote_allowed_operators = m s qr qx + +# The operators to allow double-quotes as delimiters for. +# Valid values: m, q, qq, qr, qw, qx, s, tr, y. +# double_quote_allowed_operators = + +# The operators to allow back-quotes (back-ticks) as delimiters for. +# Valid values: m, q, qq, qr, qw, qx, s, tr, y. +# back_quote_allowed_operators = + + +# Don't write ` print <<'__END__' '. +[ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] +# set_themes = core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Don't use strings like `v1.4' or `1.4.5' when including other modules. +[-ValuesAndExpressions::ProhibitVersionStrings] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Require $VERSION to be a constant rather than a computed value. +[ValuesAndExpressions::RequireConstantVersion] +# set_themes = core maintenance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# Allow qv() and version->new() without a 'use version' on the same line. +# allow_version_without_use_on_same_line = 0 + + +# Warns that you might have used single quotes when you really wanted double-quotes. +[-ValuesAndExpressions::RequireInterpolationOfMetachars] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 1 +# maximum_violations_per_document = no_limit + +# RCS keywords to ignore in potential interpolation. +# rcs_keywords = + + +# Write ` 141_234_397.0145 ' instead of ` 141234397.0145 '. +[ValuesAndExpressions::RequireNumberSeparators] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The minimum absolute value to require separators in. +# Minimum value 10. No maximum. +# min_value = 10_000 + + +# Write ` print <<'THE_END' ' or ` print <<"THE_END" '. +[-ValuesAndExpressions::RequireQuotedHeredocTerminator] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write ` <<'THE_END'; ' instead of ` <<'theEnd'; '. +[ValuesAndExpressions::RequireUpperCaseHeredocTerminator] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Do not write ` my $foo .= 'bar'; '. +[Variables::ProhibitAugmentedAssignmentInDeclaration] +# set_themes = bugs core +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Allow augmented assignment for our variables. +# allow_our = 0 + + +# Do not write ` my $foo = $bar if $baz; '. +[Variables::ProhibitConditionalDeclarations] +# set_themes = bugs core +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Use `my' instead of `local', except when you have to. +[Variables::ProhibitLocalVars] +# set_themes = core maintenance pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Avoid `$`', `$&', `$'' and their English equivalents. +[Variables::ProhibitMatchVars] +# set_themes = core pbp performance +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + + +# Eliminate globals declared with `our' or `use vars'. +[Variables::ProhibitPackageVars] +# set_themes = core maintenance pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The base set of packages to allow variables for. +# packages = Data::Dumper File::Find FindBin Log::Log4perl Test::Builder Text::Wrap + +# The set of packages to allow variables for, in addition to those given in "packages". +add_packages = DBI + + +# Use double colon (::) to separate package name components instead of single quotes ('). +[Variables::ProhibitPerl4PackageNames] +# set_themes = certrec core maintenance +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + + +# Write `$EVAL_ERROR' instead of `$@'. +[-Variables::ProhibitPunctuationVars] +# set_themes = core cosmetic pbp +# add_themes = +# severity = 2 +# maximum_violations_per_document = no_limit + +# The additional variables to allow. +# Values that are always included: $1, $2, $3, $4, $5, $6, $7, $8, $9, $], $_, @_, _. +# allow = + +# Controls checking interpolated strings for punctuation variables. +# Valid values: disable, simple, thorough. +# string_mode = thorough + + +# Do not reuse a variable name in a lexical scope +[Variables::ProhibitReusedNames] +# set_themes = bugs core +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + +# The variables to not consider as duplicates. +# allow = $self $class + + +# Don't ask for storage you don't need. +[Variables::ProhibitUnusedVariables] +# set_themes = certrec core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Prevent access to private vars in other packages. +[Variables::ProtectPrivateVars] +# set_themes = certrule core maintenance +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `local $foo = $bar;' instead of just `local $foo;'. +[-Variables::RequireInitializationForLocalVars] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 3 +# maximum_violations_per_document = no_limit + + +# Write `for my $element (@list) {...}' instead of `for $element (@list) {...}'. +[Variables::RequireLexicalLoopIterators] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 5 +# maximum_violations_per_document = no_limit + + +# Magic variables should be assigned as "local". +[Variables::RequireLocalizedPunctuationVars] +# set_themes = bugs certrec core pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit + +# Global variables to exclude from this policy. +# Values that are always included: $ARG, $_, @_. +allow = %ENV %SIG $> $0 + + +# Negative array index should be used. +[Variables::RequireNegativeIndices] +# set_themes = core maintenance pbp +# add_themes = +# severity = 4 +# maximum_violations_per_document = no_limit diff --git a/.perltidyrc b/.perltidyrc new file mode 100644 index 00000000..0c172ab0 --- /dev/null +++ b/.perltidyrc @@ -0,0 +1,51 @@ +-utf8 # input is UTF-8 +--converge # keep running until no changes +--output-line-ending=unix # output uses unix line endings + +--indent-columns=2 # indent level is 2 cols +--extended-continuation-indentation # indent extended continuations +--no-outdent-long-lines # don't outdent long lines +--no-outdent-labels # don't outdent labels +--no-outdent-long-comments # don't outdent long comments + +--paren-tightness=2 # keep parentheses tight +--space-prototype-paren=2 # space before prototype parentheses +# --space-signature-paren=2 # space before signature parentheses + # needs a recent Perl::Tidy +--keyword-paren-inner-tightness=2 # keep keyword parentheses tight +--space-backslash-quote=0 # no space between backslash and quote +--minimum-space-to-comment=2 # spaces before side comments +--break-before-all-operators # break before all operators +--break-after-all-operators # break after all operators +--no-space-for-semicolon # no space before semicolons in for loops + +--no-add-semicolons # no optional semicolons at end of blocks +--one-line-block-semicolons=0 # no semicolons after one-line blocks +--one-line-block-nesting=1 # use one line block nesting +--delete-closing-side-comments # delete closing side comments +--no-blanks-before-comments # no blank lines before comments + +--cuddled-else # cuddle elses +--cuddled-block-list=sort,map,grep # cuddle blocks for sort, map, grep +--cuddled-paren-brace # cuddle paren-brace blocks ) { +--opening-token-right # no break between comma and bracket , { +--vertical-tightness=0 # break after every bracket +--brace-follower-vertical-tightness=2 # keep code after brace on same line +--weld-nested-containers # allow container delimiters on same line +--weld-fat-comma # allow fat comma on same line +# --comma-arrow-breakpoints=3 # commas after => aren't special + # we only want this sometimes +--break-after-labels=2 # never break after labels +--valign-if-unless # vertically align if and unless + +--delete-repeated-commas # delete repeated commas +--want-trailing-commas="w(h W(m [m {m" # trailing commas for arrays and hashes +--add-trailing-commas # add trailing commas +--delete-trailing-commas # delete trailing commas +--delete-weld-interfering-commas # delete commas that interfere with welds + +--ignore-old-breakpoints # ignore all old breakpoints + +--keep-old-blank-lines=1 # keep existing blank lines +--keyword-group-blanks # add blank lines between keyword groups +--keyword-group-blanks-size=5 # size of keyword groups diff --git a/.shellcheckrc b/.shellcheckrc new file mode 100644 index 00000000..b5fad094 --- /dev/null +++ b/.shellcheckrc @@ -0,0 +1,7 @@ +shell=bash +external-sources=true +enable=add-default-case +enable=avoid-nullary-conditions +enable=check-unassigned-uppercase +enable=deprecate-which +enable=require-double-brackets diff --git a/.typos.toml b/.typos.toml new file mode 100644 index 00000000..32d4ea50 --- /dev/null +++ b/.typos.toml @@ -0,0 +1,21 @@ +[files] + extend-exclude = [ ".codespell" ] + ignore-hidden = false + +[default.extend-words] + thr = "thr" + +[default.extend-identifiers] + +[default] + +extend-ignore-words-re = [ +] + +extend-ignore-identifiers-re = [ +] + +extend-ignore-re = [ + '"[^"]+"\n\n__END__\n\n', # quotes + '::ProhibitMultipleWiths\b', # perl critic +] diff --git a/Cover.xs b/Cover.xs index 31d591bb..3cecd407 100644 --- a/Cover.xs +++ b/Cover.xs @@ -1,5 +1,5 @@ /* - * Copyright 2001-2023, Paul Johnson (paul@pjcj.net) + * Copyright 2001-2024, Paul Johnson (paul@pjcj.net) * * This software is free. It is licensed under the same terms as Perl itself. * diff --git a/Makefile.PL b/Makefile.PL index 561b80eb..0c5f29d6 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -35,7 +35,7 @@ chomp (my $inc_string = $dumper->Dump); open I, ">lib/Devel/Cover/Inc.pm" or die "Cannot open lib/Devel/Cover/Inc.pm: $!"; print I <<"EOI"; -# Copyright 2001-2023, Paul Johnson (paul\@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul\@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -105,7 +105,7 @@ for my $t (readdir D) { print T < $] < 5.008008 ? - { - FILES => "lib/Devel/Cover/Inc.pm", - POSTOP => "\$(RM_RF) cover_db t/e2e" - } : - { FILES => "lib/Devel/Cover/Inc.pm cover_db t/e2e" }, + realclean => { FILES => "lib/Devel/Cover/Inc.pm cover_db t/e2e" }, }; # use Data::Dumper; print Dumper $opts; WriteMakefile(%$opts); diff --git a/bin/cover b/bin/cover index 0bcef062..78e560b4 100755 --- a/bin/cover +++ b/bin/cover @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -101,7 +101,7 @@ sub get_options { $Options->{report} = ["html"] if !@{$Options->{report}} && !exists $Options->{write}; - # handle comma seperated ops, like -coverage branch,statement + # handle comma separated ops, like -coverage branch,statement # also accept them in the same format they're output my %coverage_abbrev = ( @@ -174,7 +174,7 @@ sub mb_test_command { my $test = "$builder test"; if ($Options->{gcov}) { my $c = my $l = gcov_args(); - if (my $params = do './_build/build_params') { + if (my $params = do("./_build/build_params")) { $c = join(' ', @{$params->[-1]{extra_compiler_flags} || []}, $c); $l = join(' ', @{$params->[-1]{extra_linker_flags} || []}, $c); } @@ -229,7 +229,7 @@ sub main { push @{$Options->{annotations}}, $ann; } - print "$0 version $VERSION\n" and exit 0 if $Options->{version}; + print "$0 version $VERSION\n" and exit 0 if $Options->{version}; pod2usage(-exitval => 0, -verbose => 1) if $Options->{help}; pod2usage(-exitval => 0, -verbose => 2) if $Options->{info}; @@ -310,7 +310,9 @@ sub main { print STDERR "cover: running @c\n"; system @c; }; - File::Find::find({ wanted => $gc, no_chdir => !$Options->{gcov_chdir} }, "."); + File::Find::find( + { wanted => $gc, no_chdir => !$Options->{gcov_chdir} }, "." + ); my @gc; my $gp = sub { return unless /\.gcov$/; @@ -643,7 +645,7 @@ See the BUGS file. =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/bin/cpancover b/bin/cpancover index 70f2733f..18a64670 100755 --- a/bin/cpancover +++ b/bin/cpancover @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -216,7 +216,7 @@ The following exit values are returned: =head1 LICENCE -Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +Copyright 2002-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/bin/gcov2perl b/bin/gcov2perl index a3e8f9e1..1503c186 100755 --- a/bin/gcov2perl +++ b/bin/gcov2perl @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -214,7 +214,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover.pm b/lib/Devel/Cover.pm index 6b0227e2..6b39fcc7 100644 --- a/lib/Devel/Cover.pm +++ b/lib/Devel/Cover.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -11,8 +11,9 @@ use strict; use warnings; our $VERSION; + BEGIN { -# VERSION + # VERSION } use DynaLoader (); @@ -36,464 +37,464 @@ use Devel::Cover::Dumper; use Devel::Cover::Util "remove_contained_paths"; BEGIN { - # Use Pod::Coverage if it is available - eval "use Pod::Coverage 0.06"; - # If there is any error other than a failure to locate, report it - die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; - - # We'll prefer Pod::Coverage::CountParents - eval "use Pod::Coverage::CountParents"; - die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; + # Use Pod::Coverage if it is available + eval "use Pod::Coverage 0.06"; + # If there is any error other than a failure to locate, report it + die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; + + # We'll prefer Pod::Coverage::CountParents + eval "use Pod::Coverage::CountParents"; + die $@ if $@ && $@ !~ m/Can't locate Pod\/Coverage.+pm in \@INC/; } # $SIG{__DIE__} = \&Carp::confess; # sub Pod::Coverage::TRACE_ALL () { 1 } -my $Initialised; # import() has been called - -my $Dir; # Directory in which coverage will be - # collected -my $DB = "cover_db"; # DB name -my $Merge = 1; # Merge databases -my $Summary = 1; # Output coverage summary -my $Subs_only = 0; # Coverage only for sub bodies -my $Self_cover_run = 0; # Covering Devel::Cover now -my $Loose_perms = 0; # Use loose permissions in the cover DB - -my @Ignore; # Packages to ignore -my @Inc; # Original @INC to ignore -my @Select; # Packages to select -my @Ignore_re; # Packages to ignore -my @Inc_re; # Original @INC to ignore -my @Select_re; # Packages to select - -my $Pod = $INC{"Pod/Coverage/CountParents.pm"} ? "Pod::Coverage::CountParents" - : $INC{"Pod/Coverage.pm"} ? "Pod::Coverage" - : ""; # Type of pod coverage available -my %Pod; # Pod coverage data - -my @Cvs; # All the Cvs we want to cover -my %Cvs; # All the Cvs we want to cover -my @Subs; # All the subs we want to cover -my $Cv; # Cv we are looking in -my $Sub_name; # Name of the sub we are looking in -my $Sub_count; # Count for multiple subs on same line - -my $Coverage; # Raw coverage data -my $Structure; # Structure of the files -my $Digests; # Digests of the files - -my %Criteria; # Names of coverage criteria -my %Coverage; # Coverage criteria to collect -my %Coverage_options; # Options for overage criteria - -my %Run; # Data collected from the run +my $Initialised; # import() has been called + +my $Dir; # Directory in which coverage will be + # collected +my $DB = "cover_db"; # DB name +my $Merge = 1; # Merge databases +my $Summary = 1; # Output coverage summary +my $Subs_only = 0; # Coverage only for sub bodies +my $Self_cover_run = 0; # Covering Devel::Cover now +my $Loose_perms = 0; # Use loose permissions in the cover DB + +my @Ignore; # Packages to ignore +my @Inc; # Original @INC to ignore +my @Select; # Packages to select +my @Ignore_re; # Packages to ignore +my @Inc_re; # Original @INC to ignore +my @Select_re; # Packages to select + +my $Pod + = $INC{"Pod/Coverage/CountParents.pm"} ? "Pod::Coverage::CountParents" + : $INC{"Pod/Coverage.pm"} ? "Pod::Coverage" + : ""; # Type of pod coverage available +my %Pod; # Pod coverage data + +my @Cvs; # All the Cvs we want to cover +my %Cvs; # All the Cvs we want to cover +my @Subs; # All the subs we want to cover +my $Cv; # Cv we are looking in +my $Sub_name; # Name of the sub we are looking in +my $Sub_count; # Count for multiple subs on same line + +my $Coverage; # Raw coverage data +my $Structure; # Structure of the files +my $Digests; # Digests of the files + +my %Criteria; # Names of coverage criteria +my %Coverage; # Coverage criteria to collect +my %Coverage_options; # Options for overage criteria + +my %Run; # Data collected from the run my $Const_right = qr/^(?:const|s?refgen|gelem|die|undef|bless|anon(?:list|hash)| emptyavhv|scalar|return|last|next|redo|goto)$/x; - # constant ops - -our $File; # Last filename we saw. (localised) -our $Line; # Last line number we saw. (localised) -our $Collect; # Whether or not we are collecting - # coverage data. We make two passes - # over conditions. (localised) -our %Files; # Whether we are interested in files - # Used in runops function -our $Replace_ops; # Whether we are replacing ops -our $Silent; # Output nothing. Can be used anywhere -our $Ignore_covered_err; # Don't flag an error when uncoverable - # code is covered. -our $Self_cover; # Coverage of Devel::Cover -BEGIN { - ($File, $Line, $Collect) = ("", 0, 1); - $Silent = ($ENV{HARNESS_PERL_SWITCHES} || "") =~ /Devel::Cover/ || - ($ENV{PERL5OPT} || "") =~ /Devel::Cover/; - *OUT = $ENV{DEVEL_COVER_DEBUG} ? *STDERR : *STDOUT; +# constant ops + +our $File; # Last filename we saw. (localised) +our $Line; # Last line number we saw. (localised) +our $Collect; # Whether or not we are collecting + # coverage data. We make two passes + # over conditions. (localised) +our %Files; # Whether we are interested in files + # Used in runops function +our $Replace_ops; # Whether we are replacing ops +our $Silent; # Output nothing. Can be used anywhere +our $Ignore_covered_err; # Don't flag an error when uncoverable + # code is covered. +our $Self_cover; # Coverage of Devel::Cover - if ($^X =~ /(apache2|httpd)$/) { - # mod_perl < 2.0.8 - @Inc = @Devel::Cover::Inc::Inc; +BEGIN { + ($File, $Line, $Collect) = ("", 0, 1); + $Silent = ($ENV{HARNESS_PERL_SWITCHES} || "") =~ /Devel::Cover/ + || ($ENV{PERL5OPT} || "") =~ /Devel::Cover/; + *OUT = $ENV{DEVEL_COVER_DEBUG} ? *STDERR : *STDOUT; + + if ($^X =~ /(apache2|httpd)$/) { + # mod_perl < 2.0.8 + @Inc = @Devel::Cover::Inc::Inc; + } else { + # Can't get @INC via eval `` in taint mode, revert to default value + if (${^TAINT}) { + @Inc = @Devel::Cover::Inc::Inc; } else { - # Can't get @INC via eval `` in taint mode, revert to default value - if (${^TAINT}) { - @Inc = @Devel::Cover::Inc::Inc; - } else { - eval { - local %ENV = %ENV; - # Clear *PERL* variables, but keep PERL5?LIB for local::lib - # environments - /perl/i and !/^PERL5?LIB$/ and delete $ENV{$_} for keys %ENV; - my $cmd = "$^X -MData::Dumper -e " . '"print Dumper \@INC"'; - my $VAR1; - # print STDERR "Running [$cmd]\n"; - eval `$cmd`; - @Inc = @$VAR1; - }; - if ($@) { - print STDERR __PACKAGE__, - ": Error getting \@INC: $@\n", - "Reverting to default value for Inc.\n"; - @Inc = @Devel::Cover::Inc::Inc; - } - } + eval { + local %ENV = %ENV; + # Clear *PERL* variables, but keep PERL5?LIB for local::lib + # environments + /perl/i and !/^PERL5?LIB$/ and delete $ENV{$_} for keys %ENV; + my $cmd = "$^X -MData::Dumper -e " . '"print Dumper \@INC"'; + my $VAR1; + # print STDERR "Running [$cmd]\n"; + eval `$cmd`; + @Inc = @$VAR1; + }; + if ($@) { + print STDERR __PACKAGE__, ": Error getting \@INC: $@\n", + "Reverting to default value for Inc.\n"; + @Inc = @Devel::Cover::Inc::Inc; + } } + } - @Inc = map { -d $_ ? ($_ eq "." ? $_ : Cwd::abs_path($_)) : () } @Inc; + @Inc = map { -d $_ ? ($_ eq "." ? $_ : Cwd::abs_path($_)) : () } @Inc; - @Inc = remove_contained_paths(getcwd, @Inc); + @Inc = remove_contained_paths(getcwd, @Inc); - @Ignore = ("/Devel/Cover[./]") unless $Self_cover = $ENV{DEVEL_COVER_SELF}; - # $^P = 0x004 | 0x010 | 0x100 | 0x200; - # $^P = 0x004 | 0x100 | 0x200; - $^P |= 0x004 | 0x100; + @Ignore = ("/Devel/Cover[./]") unless $Self_cover = $ENV{DEVEL_COVER_SELF}; + # $^P = 0x004 | 0x010 | 0x100 | 0x200; + # $^P = 0x004 | 0x100 | 0x200; + $^P |= 0x004 | 0x100; } sub version { $VERSION } if (0 && $Config{useithreads}) { - eval "use threads"; + eval "use threads"; - no warnings "redefine"; + no warnings "redefine"; + + my $original_join; + BEGIN { $original_join = \&threads::join } + # print STDERR "original_join: $original_join\n"; + + # $original_join = sub { print STDERR "j\n" }; - my $original_join; - BEGIN { $original_join = \&threads::join } - # print STDERR "original_join: $original_join\n"; - - # $original_join = sub { print STDERR "j\n" }; - - # sub threads::join - *threads::join = sub { - # print STDERR "threads::join- ", \&threads::join, "\n"; - # print STDERR "original_join- $original_join\n"; - my $self = shift; - print STDERR "(joining thread ", $self->tid, ")\n"; - my @ret = $original_join->($self, @_); - print STDERR "(returning <@ret>)\n"; - @ret - }; - - my $original_destroy; - BEGIN { $original_destroy = \&threads::DESTROY } - - *threads::DESTROY = sub { - my $self = shift; - print STDERR "(destroying thread ", $self->tid, ")\n"; - $original_destroy->($self, @_); - }; - - # print STDERR "threads::join: ", \&threads::join, "\n"; - - my $new = \&threads::new; - *threads::new = *threads::create = sub { - my $class = shift; - my $sub = shift; - my $wantarray = wantarray; - - $new->( - $class, - sub { - print STDERR "Starting thread\n"; - set_coverage(keys %Coverage); - my $ret = [ $sub->(@_) ]; - print STDERR "Ending thread\n"; - report() if $Initialised; - print STDERR "Ended thread\n"; - $wantarray ? @{$ret} : $ret->[0]; - }, - @_ - ); - }; + # sub threads::join + *threads::join = sub { + # print STDERR "threads::join- ", \&threads::join, "\n"; + # print STDERR "original_join- $original_join\n"; + my $self = shift; + print STDERR "(joining thread ", $self->tid, ")\n"; + my @ret = $original_join->($self, @_); + print STDERR "(returning <@ret>)\n"; + @ret + }; + + my $original_destroy; + BEGIN { $original_destroy = \&threads::DESTROY } + + *threads::DESTROY = sub { + my $self = shift; + print STDERR "(destroying thread ", $self->tid, ")\n"; + $original_destroy->($self, @_); + }; + + # print STDERR "threads::join: ", \&threads::join, "\n"; + + my $new = \&threads::new; + *threads::new = *threads::create = sub { + my $class = shift; + my $sub = shift; + my $wantarray = wantarray; + + $new->( + $class, + sub { + print STDERR "Starting thread\n"; + set_coverage(keys %Coverage); + my $ret = [ $sub->(@_) ]; + print STDERR "Ending thread\n"; + report() if $Initialised; + print STDERR "Ended thread\n"; + $wantarray ? @{$ret} : $ret->[0]; + }, + @_, + ); + }; } { - sub check { - return unless $Initialised; - check_files(); + sub check { + return unless $Initialised; - set_coverage(keys %Coverage); - my @coverage = get_coverage(); - %Coverage = map { $_ => 1 } @coverage; - - delete $Coverage{path}; # not done yet - my $nopod = ""; - if (!$Pod && exists $Coverage{pod}) { - delete $Coverage{pod}; # Pod::Coverage unavailable - $nopod = < 1 } @coverage; + + delete $Coverage{path}; # not done yet + my $nopod = ""; + if (!$Pod && exists $Coverage{pod}) { + delete $Coverage{pod}; # Pod::Coverage unavailable + $nopod = <rel2abs($DB, $Dir); - unless (mkdir $DB) { - my $err = $!; - die "Can't mkdir $DB as EUID $>: $err" unless -d $DB; - } - chmod 0777, $DB if $Loose_perms; - $DB = $1 if abs_path($DB) =~ /(.*)/; - Devel::Cover::DB->delete($DB) unless $Merge; - - %Files = (); # start gathering file information from scratch - - for my $c (Devel::Cover::DB->new->criteria) { - my $func = "coverage_$c"; - no strict "refs"; - $Criteria{$c} = $func->(); - } - - for (keys %Coverage) { - my @c = split /-/, $_; - if (@c > 1) { - $Coverage{shift @c} = \@c; - delete $Coverage{$_}; - } - delete $Coverage{$_} unless length; - } - %Coverage = (all => 1) unless keys %Coverage; - # print STDERR "Coverage: ", Dumper \%Coverage; - %Coverage_options = %Coverage; - - $Initialised = 1; - - if ($ENV{MOD_PERL}) { - eval "BEGIN {}"; - check(); - set_first_init_and_end(); + return if $Initialised; + + my $class = shift; + + # Die tainting + # Anyone using this module can do worse things than messing with tainting + my $options = ($ENV{DEVEL_COVER_OPTIONS} || "") =~ /(.*)/ ? $1 : ""; + my @o = (@_, split ",", $options); + defined or $_ = "" for @o; + # print STDERR __PACKAGE__, ": Parsing options from [@o]\n"; + + my $blib = -d "blib"; + @Inc = () if "@o" =~ /-inc /; + @Ignore = () if "@o" =~ /-ignore /; + @Select = () if "@o" =~ /-select /; + while (@o) { + local $_ = shift @o; + /^-silent/ && do { $Silent = shift @o; next }; + /^-dir/ && do { $Dir = shift @o; next }; + /^-db/ && do { $DB = shift @o; next }; + /^-loose_perms/ && do { $Loose_perms = shift @o; next }; + /^-merge/ && do { $Merge = shift @o; next }; + /^-summary/ && do { $Summary = shift @o; next }; + /^-blib/ && do { $blib = shift @o; next }; + /^-subs_only/ && do { $Subs_only = shift @o; next }; + /^-replace_ops/ && do { $Replace_ops = shift @o; next }; + /^-coverage/ + && do { $Coverage{ +shift @o } = 1 while @o && $o[0] !~ /^[-+]/; next }; + /^[-+]ignore/ + && do { push @Ignore, shift @o while @o && $o[0] !~ /^[-+]/; next }; + /^[-+]inc/ && do { push @Inc, shift @o while @o && $o[0] !~ /^[-+]/; next }; + /^[-+]select/ + && do { push @Select, shift @o while @o && $o[0] !~ /^[-+]/; next }; + warn __PACKAGE__ . ": Unknown option $_ ignored\n"; + } + + if ($blib) { + eval "use blib"; + for (@INC) { $_ = $1 if ref $_ ne 'CODE' && /(.*)/ } # Die tainting + push @Ignore, "^t/", '\\.t$', '^test\\.pl$'; + } + + my $ci = $^O eq "MSWin32"; + @Select_re = map qr/$_/, @Select; + @Ignore_re = map qr/$_/, @Ignore; + @Inc_re = map $ci ? qr/^\Q$_\//i : qr/^\Q$_\//, @Inc; + + bootstrap Devel::Cover $VERSION; + + if (defined $Dir) { + $Dir = $1 if $Dir =~ /(.*)/; # Die tainting + } else { + $Dir = $1 if Cwd::getcwd() =~ /(.*)/; + } + + $DB = File::Spec->rel2abs($DB, $Dir); + unless (mkdir $DB) { + my $err = $!; + die "Can't mkdir $DB as EUID $>: $err" unless -d $DB; + } + chmod 0777, $DB if $Loose_perms; + $DB = $1 if abs_path($DB) =~ /(.*)/; + Devel::Cover::DB->delete($DB) unless $Merge; + + %Files = (); # start gathering file information from scratch + + for my $c (Devel::Cover::DB->new->criteria) { + my $func = "coverage_$c"; + no strict "refs"; + $Criteria{$c} = $func->(); + } + + for (keys %Coverage) { + my @c = split /-/, $_; + if (@c > 1) { + $Coverage{ shift @c } = \@c; + delete $Coverage{$_}; } + delete $Coverage{$_} unless length; + } + %Coverage = (all => 1) unless keys %Coverage; + # print STDERR "Coverage: ", Dumper \%Coverage; + %Coverage_options = %Coverage; + + $Initialised = 1; + + if ($ENV{MOD_PERL}) { + eval "BEGIN {}"; + check(); + set_first_init_and_end(); + } } sub populate_run { - my $self = shift; - - $Run{OS} = $^O; - $Run{perl} = $] < 5.010 ? join ".", map ord, split //, $^V - : sprintf "%vd", $^V; - $Run{dir} = $Dir; - $Run{run} = $0; - $Run{name} = $Dir; - $Run{version} = "unknown"; - - my $mymeta = "$Dir/MYMETA.json"; - if (-e $mymeta) { - eval { - require CPAN::Meta; - my $json = CPAN::Meta->load_file($mymeta)->as_struct; - $Run{$_} = $json->{$_} for qw( name version abstract ); - } - } elsif ($Dir =~ m|.*/([^/]+)$|) { - my $filename = $1; - eval { - require CPAN::DistnameInfo; - my $dinfo = CPAN::DistnameInfo->new($filename); - $Run{name} = $dinfo->dist; - $Run{version} = $dinfo->version; - } + my $self = shift; + + $Run{OS} = $^O; + $Run{perl} = $] < 5.010 ? join ".", map ord, split //, $^V : sprintf "%vd", + $^V; + $Run{dir} = $Dir; + $Run{run} = $0; + $Run{name} = $Dir; + $Run{version} = "unknown"; + + my $mymeta = "$Dir/MYMETA.json"; + if (-e $mymeta) { + eval { + require CPAN::Meta; + my $json = CPAN::Meta->load_file($mymeta)->as_struct; + $Run{$_} = $json->{$_} for qw( name version abstract ); } + } elsif ($Dir =~ m|.*/([^/]+)$|) { + my $filename = $1; + eval { + require CPAN::DistnameInfo; + my $dinfo = CPAN::DistnameInfo->new($filename); + $Run{name} = $dinfo->dist; + $Run{version} = $dinfo->version; + } + } - $Run{start} = get_elapsed() / 1e6; + $Run{start} = get_elapsed() / 1e6; } -sub cover_names_to_val -{ - my $val = 0; - for my $c (@_) { - if (exists $Criteria{$c}) { - $val |= $Criteria{$c}; - } elsif ($c eq "all" || $c eq "none") { - my $func = "coverage_$c"; - no strict "refs"; - $val |= $func->(); - } else { - warn __PACKAGE__ . qq(: Unknown coverage criterion "$c" ignored.\n); - } +sub cover_names_to_val { + my $val = 0; + for my $c (@_) { + if (exists $Criteria{$c}) { + $val |= $Criteria{$c}; + } elsif ($c eq "all" || $c eq "none") { + my $func = "coverage_$c"; + no strict "refs"; + $val |= $func->(); + } else { + warn __PACKAGE__ . qq(: Unknown coverage criterion "$c" ignored.\n); } - $val; + } + $val; } -sub set_coverage { set_criteria(cover_names_to_val(@_)) } -sub add_coverage { add_criteria(cover_names_to_val(@_)) } +sub set_coverage { set_criteria(cover_names_to_val(@_)) } +sub add_coverage { add_criteria(cover_names_to_val(@_)) } sub remove_coverage { remove_criteria(cover_names_to_val(@_)) } sub get_coverage { - return unless defined wantarray; - my @names; - my $val = get_criteria(); - for my $c (sort keys %Criteria) { - push @names, $c if $val & $Criteria{$c}; - } - return wantarray ? @names : "@names"; + return unless defined wantarray; + my @names; + my $val = get_criteria(); + for my $c (sort keys %Criteria) { + push @names, $c if $val & $Criteria{$c}; + } + return wantarray ? @names : "@names"; } { -my %File_cache; + my %File_cache; -# Recursion in normalised_file() is bad. It can happen if a call from the sub -# evals something which wants to load a new module. This has happened with -# the Storable backend. I don't think it happens with the JSON backend. -my $Normalising; + # Recursion in normalised_file() is bad. It can happen if a call from the sub + # evals something which wants to load a new module. This has happened with + # the Storable backend. I don't think it happens with the JSON backend. + my $Normalising; -sub normalised_file { + sub normalised_file { my ($file) = @_; return $File_cache{$file} if exists $File_cache{$file}; - return $file if $Normalising; + return $file if $Normalising; $Normalising = 1; my $f = $file; $file =~ s/ \(autosplit into .*\)$//; $file =~ s/^\(eval in .*\) //; # print STDERR "file is <$file>\ncoverage: ", Dumper coverage(0); - if (exists coverage(0)->{module} && exists coverage(0)->{module}{$file} && - !File::Spec->file_name_is_absolute($file)) { - my $m = coverage(0)->{module}{$file}; - # print STDERR "Loaded <$file> <$m->[0]> from <$m->[1]> "; - $file = File::Spec->rel2abs($file, $m->[1]); - # print STDERR "as <$file> "; + if ( exists coverage(0)->{module} + && exists coverage(0)->{module}{$file} + && !File::Spec->file_name_is_absolute($file)) + { + my $m = coverage(0)->{module}{$file}; + # print STDERR "Loaded <$file> <$m->[0]> from <$m->[1]> "; + $file = File::Spec->rel2abs($file, $m->[1]); + # print STDERR "as <$file> "; } my $inc; $inc ||= $file =~ $_ for @Inc_re; # warn "inc for [$file] is [$inc] @Inc_re"; if ($inc && ($^O eq "MSWin32" || $^O eq "cygwin")) { - # Windows' Cwd::_win32_cwd() calls eval which will recurse back - # here if we call abs_path, so we just assume it's normalised. - # warn "giving up on getting normalised filename from <$file>\n"; + # Windows' Cwd::_win32_cwd() calls eval which will recurse back + # here if we call abs_path, so we just assume it's normalised. + # warn "giving up on getting normalised filename from <$file>\n"; } else { - # print STDERR "getting abs_path <$file> "; - if (-e $file) { # Windows likes the file to exist - my $abs; - $abs = abs_path($file) unless -l $file; # leave symbolic links - # print STDERR "giving <$abs> "; - $file = $abs if defined $abs; - } + # print STDERR "getting abs_path <$file> "; + if (-e $file) { # Windows likes the file to exist + my $abs; + $abs = abs_path($file) unless -l $file; # leave symbolic links + # print STDERR "giving <$abs> "; + $file = $abs if defined $abs; + } } # print STDERR "finally <$file> <$Dir>\n"; - $file =~ s|\\|/|g if $^O eq "MSWin32"; + $file =~ s|\\|/|g if $^O eq "MSWin32"; $file =~ s|^\Q$Dir\E/|| if defined $Dir; $Digests ||= Devel::Cover::DB::Digests->new(db => $DB); @@ -503,33 +504,33 @@ sub normalised_file { $Normalising = 0; $File_cache{$f} = $file -} + } } sub get_location { - my ($op) = @_; - - # print STDERR "get_location ", $op, "\n"; - # use Carp "cluck"; cluck("from here"); - return unless $op->can("file"); # How does this happen? - $File = $op->file; - $Line = $op->line; - # print STDERR "$File:$Line\n"; - - # If there's an eval, get the real filename. Enabled from $^P & 0x100. - while ($File =~ /^\(eval \d+\)\[(.*):(\d+)\]/) { - ($File, $Line) = ($1, $2); - } - $File = normalised_file($File); - - if (!exists $Run{vec}{$File} && $Run{collected}) { - my %vec; - @vec{@{$Run{collected}}} = (); - delete $vec{time}; - $vec{subroutine}++ if exists $vec{pod}; - @{$Run{vec}{$File}{$_}}{"vec", "size"} = ("", 0) for keys %vec; - } + my ($op) = @_; + + # print STDERR "get_location ", $op, "\n"; + # use Carp "cluck"; cluck("from here"); + return unless $op->can("file"); # How does this happen? + $File = $op->file; + $Line = $op->line; + # print STDERR "$File:$Line\n"; + + # If there's an eval, get the real filename. Enabled from $^P & 0x100. + while ($File =~ /^\(eval \d+\)\[(.*):(\d+)\]/) { + ($File, $Line) = ($1, $2); + } + $File = normalised_file($File); + + if (!exists $Run{vec}{$File} && $Run{collected}) { + my %vec; + @vec{ @{ $Run{collected} } } = (); + delete $vec{time}; + $vec{subroutine}++ if exists $vec{pod}; + @{ $Run{vec}{$File}{$_} }{ "vec", "size" } = ("", 0) for keys %vec; + } } my $find_filename = qr/ @@ -540,169 +541,170 @@ my $find_filename = qr/ /x; sub use_file { - # If we're in global destruction, forget it - return unless $find_filename; + # If we're in global destruction, forget it + return unless $find_filename; - my ($file) = @_; + my ($file) = @_; - # print STDERR "use_file($file)\n"; + # print STDERR "use_file($file)\n"; - # die "bad file" unless length $file; + # die "bad file" unless length $file; - # If you call your file something that matches $find_filename then things - # might go awry. But it would be silly to do that, so don't. This little - # optimisation provides a reasonable speedup. - return $Files{$file} if exists $Files{$file}; + # If you call your file something that matches $find_filename then things + # might go awry. But it would be silly to do that, so don't. This little + # optimisation provides a reasonable speedup. + return $Files{$file} if exists $Files{$file}; - # just don't call your filenames 0 - while ($file =~ $find_filename) { $file = $1 || $2 || $3 || $4 } - $file =~ s/ \(autosplit into .*\)$//; + # just don't call your filenames 0 + while ($file =~ $find_filename) { $file = $1 || $2 || $3 || $4 } + $file =~ s/ \(autosplit into .*\)$//; - # print STDERR "==> use_file($file)\n"; + # print STDERR "==> use_file($file)\n"; - return $Files{$file} if exists $Files{$file}; - return 0 if $file =~ /\(eval \d+\)/ || - $file =~ /^\.\.[\/\\]\.\.[\/\\]lib[\/\\](?:Storable|POSIX).pm$/; + return $Files{$file} if exists $Files{$file}; + return 0 + if $file =~ /\(eval \d+\)/ + || $file =~ /^\.\.[\/\\]\.\.[\/\\]lib[\/\\](?:Storable|POSIX).pm$/; - my $f = normalised_file($file); + my $f = normalised_file($file); - # print STDERR "checking <$file> <$f>\n"; - # print STDERR "checking <$file> <$f> against ", - # "select(@Select_re), ignore(@Ignore_re), inc(@Inc_re)\n"; + # print STDERR "checking <$file> <$f>\n"; + # print STDERR "checking <$file> <$f> against ", + # "select(@Select_re), ignore(@Ignore_re), inc(@Inc_re)\n"; - for (@Select_re) { return $Files{$file} = 1 if $f =~ $_ } - for (@Ignore_re) { return $Files{$file} = 0 if $f =~ $_ } - for (@Inc_re) { return $Files{$file} = 0 if $f =~ $_ } + for (@Select_re) { return $Files{$file} = 1 if $f =~ $_ } + for (@Ignore_re) { return $Files{$file} = 0 if $f =~ $_ } + for (@Inc_re) { return $Files{$file} = 0 if $f =~ $_ } - # system "pwd; ls -l '$file'"; - $Files{$file} = -e $file ? 1 : 0; - print STDERR __PACKAGE__ . qq(: Can't find file "$file" (@_): ignored.\n) - unless $Files{$file} || $Silent - || $file =~ $Devel::Cover::DB::Ignore_filenames; + # system "pwd; ls -l '$file'"; + $Files{$file} = -e $file ? 1 : 0; + print STDERR __PACKAGE__ . qq(: Can't find file "$file" (@_): ignored.\n) + unless $Files{$file} + || $Silent + || $file =~ $Devel::Cover::DB::Ignore_filenames; - add_cvs(); # add CVs now in case of symbol table manipulation - $Files{$file} + add_cvs(); # add CVs now in case of symbol table manipulation + $Files{$file} } sub check_file { - my ($cv) = @_; + my ($cv) = @_; - return unless ref($cv) eq "B::CV"; + return unless ref($cv) eq "B::CV"; - my $op = $cv->START; - return unless ref($op) eq "B::COP"; + my $op = $cv->START; + return unless ref($op) eq "B::COP"; - my $file = $op->file; - my $use = use_file($file); - # printf STDERR "%6s $file\n", $use ? "use" : "ignore"; + my $file = $op->file; + my $use = use_file($file); + # printf STDERR "%6s $file\n", $use ? "use" : "ignore"; - $use + $use } sub B::GV::find_cv { - my $cv = $_[0]->CV; - return unless $$cv; - - # print STDERR "find_cv $$cv\n" if check_file($cv); - $Cvs{$cv} ||= $cv if check_file($cv); - if ($cv->can("PADLIST") && - $cv->PADLIST->can("ARRAY") && - $cv->PADLIST->ARRAY && - $cv->PADLIST->ARRAY->can("ARRAY")) { - $Cvs{$_} ||= $_ - for grep ref eq "B::CV" && check_file($_), $cv->PADLIST->ARRAY->ARRAY; - } + my $cv = $_[0]->CV; + return unless $$cv; + + # print STDERR "find_cv $$cv\n" if check_file($cv); + $Cvs{$cv} ||= $cv if check_file($cv); + if ( $cv->can("PADLIST") + && $cv->PADLIST->can("ARRAY") + && $cv->PADLIST->ARRAY + && $cv->PADLIST->ARRAY->can("ARRAY")) + { + $Cvs{$_} ||= $_ + for grep ref eq "B::CV" && check_file($_), $cv->PADLIST->ARRAY->ARRAY; + } } sub sub_info { - my ($cv) = @_; - my ($name, $start) = ("--unknown--", 0); - my $gv = $cv->GV; - if ($gv && !$gv->isa("B::SPECIAL")) { - return unless $gv->can("SAFENAME"); - $name = $gv->SAFENAME; - # print STDERR "--[$name]--\n"; - $name =~ s/(__ANON__)\[.+:\d+\]/$1/ if defined $name; - } - # my $op = sub { my ($t, $o) = @_; print "$t\n"; $o->debug }; - my $root = $cv->ROOT; - # $op->(root => $root); - if ($root->can("first")) { - my $lineseq = $root->first; - # $op->(lineseq => $lineseq); - if ($lineseq->can("first")) { - # normal case - $start = $lineseq->first; - # $op->(start => $start); - # signatures - if ($start->name eq "null" && $start->can("first")) { - my $lineseq2 = $start->first; - # $op->(lineseq2 => $lineseq2); - if ($lineseq2->name eq "lineseq" && $lineseq2->can("first")) { - my $cop = $lineseq2->first; - # $op->(cop => $cop); - $start = $cop if $cop->name eq "nextstate"; - } - } - } elsif ($lineseq->name eq "nextstate") { - # completely empty sub - sub empty { } - $start = $lineseq; + my ($cv) = @_; + my ($name, $start) = ("--unknown--", 0); + my $gv = $cv->GV; + if ($gv && !$gv->isa("B::SPECIAL")) { + return unless $gv->can("SAFENAME"); + $name = $gv->SAFENAME; + # print STDERR "--[$name]--\n"; + $name =~ s/(__ANON__)\[.+:\d+\]/$1/ if defined $name; + } + # my $op = sub { my ($t, $o) = @_; print "$t\n"; $o->debug }; + my $root = $cv->ROOT; + # $op->(root => $root); + if ($root->can("first")) { + my $lineseq = $root->first; + # $op->(lineseq => $lineseq); + if ($lineseq->can("first")) { + # normal case + $start = $lineseq->first; + # $op->(start => $start); + # signatures + if ($start->name eq "null" && $start->can("first")) { + my $lineseq2 = $start->first; + # $op->(lineseq2 => $lineseq2); + if ($lineseq2->name eq "lineseq" && $lineseq2->can("first")) { + my $cop = $lineseq2->first; + # $op->(cop => $cop); + $start = $cop if $cop->name eq "nextstate"; } + } + } elsif ($lineseq->name eq "nextstate") { + # completely empty sub - sub empty { } + $start = $lineseq; } - ($name, $start) + } + ($name, $start) } sub add_cvs { - $Cvs{$_} ||= $_ for grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY; + $Cvs{$_} ||= $_ for grep check_file($_), B::main_cv->PADLIST->ARRAY->ARRAY; } sub check_files { - # print STDERR "Checking files\n"; + # print STDERR "Checking files\n"; - add_cvs(); + add_cvs(); - my %seen_pkg; - my %seen_cv; + my %seen_pkg; + my %seen_cv; - walksymtable(\%main::, "find_cv", sub { !$seen_pkg{$_[0]}++ }); + walksymtable(\%main::, "find_cv", sub { !$seen_pkg{ $_[0] }++ }); - my $l = sub { - my ($cv) = @_; - my $line = 0; - my ($name, $start) = sub_info($cv); - if ($start) { - local ($Line, $File); - get_location($start); - $line = $Line; - # print STDERR "$name - $File:$Line\n"; - } - $line = 0 unless defined $line; - $name = '' unless defined $name; - ($line, $name) - }; - - # print Dumper \%Cvs; - - @Cvs = map $_->[0], - sort { $a->[1] <=> $b->[1] || $a->[2] cmp $b->[2] } - map [ $_, $l->($_) ], - grep !$seen_cv{$$_}++, - values %Cvs; - - # Hack to bump up the refcount of the subs. If we don't do this then the - # subs in some modules don't seem to be around when we get to looking at - # them. I'm not sure why this is, and it seems to me that this hack could - # affect the order of destruction, but I've not seen any problems. Yet. - @Subs = map $_->object_2svref, @Cvs; + my $l = sub { + my ($cv) = @_; + my $line = 0; + my ($name, $start) = sub_info($cv); + if ($start) { + local ($Line, $File); + get_location($start); + $line = $Line; + # print STDERR "$name - $File:$Line\n"; + } + $line = 0 unless defined $line; + $name = '' unless defined $name; + ($line, $name) + }; + + # print Dumper \%Cvs; + + @Cvs = map $_->[0], + sort { $a->[1] <=> $b->[1] || $a->[2] cmp $b->[2] } map [ $_, $l->($_) ], + grep !$seen_cv{$$_}++, values %Cvs; + + # Hack to bump up the refcount of the subs. If we don't do this then the + # subs in some modules don't seem to be around when we get to looking at + # them. I'm not sure why this is, and it seems to me that this hack could + # affect the order of destruction, but I've not seen any problems. Yet. + @Subs = map $_->object_2svref, @Cvs; } my %Seen; sub report { - local $@; - eval { _report() }; - if ($@) { - print STDERR <<"EOM" unless $Silent; + local $@; + eval { _report() }; + if ($@) { + print STDERR <<"EOM" unless $Silent; Devel::Cover: Oops, it looks like something went wrong writing the coverage. It's possible that more bad things may happen but we'll try to carry on anyway as if nothing happened. At a minimum you'll @@ -712,403 +714,411 @@ Devel::Cover: Oops, it looks like something went wrong writing the coverage. $@ EOM - } - return unless $Self_cover; - $Self_cover_run = 1; - _report(); + } + return unless $Self_cover; + $Self_cover_run = 1; + _report(); } sub _report { - local @SIG{qw(__DIE__ __WARN__)}; - # $SIG{__DIE__} = \&Carp::confess; - - $Run{finish} = get_elapsed() / 1e6; - - die "Devel::Cover::import() not run: " . - "did you require instead of use Devel::Cover?\n" - unless defined $Dir; - - my @collected = get_coverage(); - return unless @collected; - set_coverage("none") unless $Self_cover; - - my $starting_dir = $1 if Cwd::getcwd() =~ /(.*)/; - chdir $Dir or die __PACKAGE__ . ": Can't chdir $Dir: $!\n"; - - $Run{collected} = \@collected; - $Structure = Devel::Cover::DB::Structure->new( - base => $DB, - loose_perms => $Loose_perms, - ); - $Structure->read_all; - $Structure->add_criteria(@collected); - # print STDERR "Start structure: ", Dumper $Structure; - - # print STDERR "Processing cover data\n@Inc\n"; - $Coverage = coverage(1) || die "No coverage data available.\n"; - # print STDERR Dumper $Coverage; - - check_files(); - - unless ($Subs_only) { - get_cover(main_cv, main_root); - get_cover_progress("BEGIN block", - B::begin_av()->isa("B::AV") ? B::begin_av()->ARRAY : ()); - if (exists &B::check_av) { - get_cover_progress("CHECK block", - B::check_av()->isa("B::AV") ? B::check_av()->ARRAY : ()); - } - # get_ends includes INIT blocks - get_cover_progress("END/INIT block", - get_ends()->isa("B::AV") ? get_ends()->ARRAY : ()); + local @SIG{qw(__DIE__ __WARN__)}; + # $SIG{__DIE__} = \&Carp::confess; + + $Run{finish} = get_elapsed() / 1e6; + + die "Devel::Cover::import() not run: " + . "did you require instead of use Devel::Cover?\n" + unless defined $Dir; + + my @collected = get_coverage(); + return unless @collected; + set_coverage("none") unless $Self_cover; + + my $starting_dir = $1 if Cwd::getcwd() =~ /(.*)/; + chdir $Dir or die __PACKAGE__ . ": Can't chdir $Dir: $!\n"; + + $Run{collected} = \@collected; + $Structure = Devel::Cover::DB::Structure->new(base => $DB, + loose_perms => $Loose_perms); + $Structure->read_all; + $Structure->add_criteria(@collected); + # print STDERR "Start structure: ", Dumper $Structure; + + # print STDERR "Processing cover data\n@Inc\n"; + $Coverage = coverage(1) || die "No coverage data available.\n"; + # print STDERR Dumper $Coverage; + + check_files(); + + unless ($Subs_only) { + get_cover(main_cv, main_root); + get_cover_progress("BEGIN block", + B::begin_av()->isa("B::AV") ? B::begin_av()->ARRAY : ()); + if (exists &B::check_av) { + get_cover_progress("CHECK block", + B::check_av()->isa("B::AV") ? B::check_av()->ARRAY : ()); } - # print STDERR "--- @Cvs\n"; - get_cover_progress("CV", @Cvs); - - my %files; - $files{$_}++ for keys %{$Run{count}}, keys %{$Run{vec}}; - for my $file (sort keys %files) { - # print STDERR "looking at $file\n"; - unless (use_file($file)) { - # print STDERR "deleting $file\n"; - delete $Run{count}->{$file}; - delete $Run{vec} ->{$file}; - $Structure->delete_file($file); - next; - } - - # $Structure->add_digest($file, \%Run); - - for my $run (keys %{$Run{vec}{$file}}) { - delete $Run{vec}{$file}{$run} unless $Run{vec}{$file}{$run}{size}; - } - - $Structure->store_counts($file); + # get_ends includes INIT blocks + get_cover_progress("END/INIT block", + get_ends()->isa("B::AV") ? get_ends()->ARRAY : ()); + } + # print STDERR "--- @Cvs\n"; + get_cover_progress("CV", @Cvs); + + my %files; + $files{$_}++ for keys %{ $Run{count} }, keys %{ $Run{vec} }; + for my $file (sort keys %files) { + # print STDERR "looking at $file\n"; + unless (use_file($file)) { + # print STDERR "deleting $file\n"; + delete $Run{count}->{$file}; + delete $Run{vec}->{$file}; + $Structure->delete_file($file); + next; } - # print STDERR "End structure: ", Dumper $Structure; - - my $run = time . ".$$." . sprintf "%05d", rand 2 ** 16; - my $cover = Devel::Cover::DB->new( - base => $DB, - runs => { $run => \%Run }, - structure => $Structure, - loose_perms => $Loose_perms, - ); + # $Structure->add_digest($file, \%Run); - my $dbrun = "$DB/runs"; - unless (mkdir $dbrun) { - die "Can't mkdir $dbrun $!" unless -d $dbrun; - } - chmod 0777, $dbrun if $Loose_perms; - $dbrun .= "/$run"; - - print OUT __PACKAGE__, ": Writing coverage database to $dbrun\n" - unless $Silent; - $cover->write($dbrun); - $Digests->write; - $cover->print_summary if $Summary && !$Silent; - - if ($Self_cover && !$Self_cover_run) { - $cover->delete; - delete $Run{vec}; + for my $run (keys %{ $Run{vec}{$file} }) { + delete $Run{vec}{$file}{$run} unless $Run{vec}{$file}{$run}{size}; } - chdir $starting_dir; + + $Structure->store_counts($file); + } + + # print STDERR "End structure: ", Dumper $Structure; + + my $run = time . ".$$." . sprintf "%05d", rand 2**16; + my $cover = Devel::Cover::DB->new( + base => $DB, + runs => { $run => \%Run }, + structure => $Structure, + loose_perms => $Loose_perms + ); + + my $dbrun = "$DB/runs"; + unless (mkdir $dbrun) { + die "Can't mkdir $dbrun $!" unless -d $dbrun; + } + chmod 0777, $dbrun if $Loose_perms; + $dbrun .= "/$run"; + + print OUT __PACKAGE__, ": Writing coverage database to $dbrun\n" + unless $Silent; + $cover->write($dbrun); + $Digests->write; + $cover->print_summary if $Summary && !$Silent; + + if ($Self_cover && !$Self_cover_run) { + $cover->delete; + delete $Run{vec}; + } + chdir $starting_dir; } sub add_subroutine_cover { - my ($op) = @_; - - get_location($op); - return unless $File; - - # print STDERR "Subroutine $Sub_name $File:$Line: ", $op->name, "\n"; - - my $key = get_key($op); - my $val = $Coverage->{statement}{$key} || 0; - my ($n, $new) = $Structure->add_count("subroutine"); - # print STDERR "******* subroutine $n - $new\n"; - $Structure->add_subroutine($File, [ $Line, $Sub_name ]) if $new; - $Run{count}{$File}{subroutine}[$n] += $val; - my $vec = $Run{vec}{$File}{subroutine}; - vec($vec->{vec}, $n, 1) = $val ? 1 : 0; - $vec->{size} = $n + 1; + my ($op) = @_; + + get_location($op); + return unless $File; + + # print STDERR "Subroutine $Sub_name $File:$Line: ", $op->name, "\n"; + + my $key = get_key($op); + my $val = $Coverage->{statement}{$key} || 0; + my ($n, $new) = $Structure->add_count("subroutine"); + # print STDERR "******* subroutine $n - $new\n"; + $Structure->add_subroutine($File, [ $Line, $Sub_name ]) if $new; + $Run{count}{$File}{subroutine}[$n] += $val; + my $vec = $Run{vec}{$File}{subroutine}; + vec($vec->{vec}, $n, 1) = $val ? 1 : 0; + $vec->{size} = $n + 1; } sub add_statement_cover { - my ($op) = @_; - - get_location($op); - return unless $File; - - # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n"; - - $Run{digests}{$File} ||= $Structure->set_file($File); - my $key = get_key($op); - my $val = $Coverage->{statement}{$key} || 0; - my ($n, $new) = $Structure->add_count("statement"); - # print STDERR "Stmt $File:$Line - $n, $new\n"; - $Structure->add_statement($File, $Line) if $new; - $Run{count}{$File}{statement}[$n] += $val; - my $vec = $Run{vec}{$File}{statement}; - vec($vec->{vec}, $n, 1) = $val ? 1 : 0; - $vec->{size} = $n + 1; - no warnings "uninitialized"; - $Run{count}{$File}{time}[$n] += $Coverage->{time}{$key} - if $Coverage{time} && - exists $Coverage->{time} && exists $Coverage->{time}{$key}; + my ($op) = @_; + + get_location($op); + return unless $File; + + # print STDERR "Stmt $File:$Line: $op $$op ", $op->name, "\n"; + + $Run{digests}{$File} ||= $Structure->set_file($File); + my $key = get_key($op); + my $val = $Coverage->{statement}{$key} || 0; + my ($n, $new) = $Structure->add_count("statement"); + # print STDERR "Stmt $File:$Line - $n, $new\n"; + $Structure->add_statement($File, $Line) if $new; + $Run{count}{$File}{statement}[$n] += $val; + my $vec = $Run{vec}{$File}{statement}; + vec($vec->{vec}, $n, 1) = $val ? 1 : 0; + $vec->{size} = $n + 1; + no warnings "uninitialized"; + $Run{count}{$File}{time}[$n] += $Coverage->{time}{$key} + if $Coverage{time} + && exists $Coverage->{time} + && exists $Coverage->{time}{$key}; } sub add_branch_cover { - return unless $Collect && $Coverage{branch}; - - my ($op, $type, $text, $file, $line) = @_; - - # return unless $Seen{branch}{$$op}++; - - $text =~ s/^\s+//; - $text =~ s/\s+$//; - - my $key = get_key($op); - my $c = $Coverage->{condition}{$key}; - - no warnings "uninitialized"; - # warn "add_branch_cover $File:$Line [$type][@{[join ', ', @$c]}]\n"; - - if ($type eq "and" || - $type eq "or" || - ($type eq "elsif" && !exists $Coverage->{branch}{$key})) { - # and => this could also be a plain if with no else or elsif - # or => this could also be an unless with no else or elsif - # elsif => no subsequent elsifs or elses - # True path taken if not short circuited. - # False path taken if short circuited. - $c = [ $c->[1] + $c->[2], $c->[3] ]; - # print STDERR "branch $type [@$c]\n"; - } else { - $c = $Coverage->{branch}{$key} || [0, 0]; - } - - my ($n, $new) = $Structure->add_count("branch"); - $Structure->add_branch($file, [ $line, { text => $text } ]) if $new; - my $ccount = $Run{count}{$file}; - if (exists $ccount->{branch}[$n]) { - $ccount->{branch}[$n][$_] += $c->[$_] for 0 .. $#$c; - } else { - $ccount->{branch}[$n] = $c; - my $vec = $Run{vec}{$File}{branch}; - vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; - } - - # warn "branch $type %x [@$c] => [@{$ccount->{branch}[$n]}]\n", $$op; + return unless $Collect && $Coverage{branch}; + + my ($op, $type, $text, $file, $line) = @_; + + # return unless $Seen{branch}{$$op}++; + + $text =~ s/^\s+//; + $text =~ s/\s+$//; + + my $key = get_key($op); + my $c = $Coverage->{condition}{$key}; + + no warnings "uninitialized"; + # warn "add_branch_cover $File:$Line [$type][@{[join ', ', @$c]}]\n"; + + if ( $type eq "and" + || $type eq "or" + || ($type eq "elsif" && !exists $Coverage->{branch}{$key})) + { + # and => this could also be a plain if with no else or elsif + # or => this could also be an unless with no else or elsif + # elsif => no subsequent elsifs or elses + # True path taken if not short circuited. + # False path taken if short circuited. + $c = [ $c->[1] + $c->[2], $c->[3] ]; + # print STDERR "branch $type [@$c]\n"; + } else { + $c = $Coverage->{branch}{$key} || [ 0, 0 ]; + } + + my ($n, $new) = $Structure->add_count("branch"); + $Structure->add_branch($file, [ $line, { text => $text } ]) if $new; + my $ccount = $Run{count}{$file}; + if (exists $ccount->{branch}[$n]) { + $ccount->{branch}[$n][$_] += $c->[$_] for 0 .. $#$c; + } else { + $ccount->{branch}[$n] = $c; + my $vec = $Run{vec}{$File}{branch}; + vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; + } + + # warn "branch $type %x [@$c] => [@{$ccount->{branch}[$n]}]\n", $$op; } sub add_condition_cover { - my ($op, $strop, $left, $right) = @_; + my ($op, $strop, $left, $right) = @_; - return unless $Collect && $Coverage{condition}; + return unless $Collect && $Coverage{condition}; - my $key = get_key($op); - # warn "Condition cover $$op from $File:$Line\n"; - # print STDERR "left: [$left]\nright: [$right]\n"; - # use Carp "cluck"; cluck("from here"); + my $key = get_key($op); + # warn "Condition cover $$op from $File:$Line\n"; + # print STDERR "left: [$left]\nright: [$right]\n"; + # use Carp "cluck"; cluck("from here"); - my $type = $op->name; - $type =~ s/assign$//; - $type = "or" if $type eq "dor"; + my $type = $op->name; + $type =~ s/assign$//; + $type = "or" if $type eq "dor"; - my $c = $Coverage->{condition}{$key}; + my $c = $Coverage->{condition}{$key}; - no warnings "uninitialized"; + no warnings "uninitialized"; - my $count; - - if ($type eq "or" || $type eq "and") { - my $r = $op->first->sibling; - my $name = $r->name; - $name = $r->first->name if $name eq "sassign"; - # TODO - exec? any others? - # print STDERR "Name [$name]", Dumper $c; - if ($c->[5] || $name =~ $Const_right) { - $c = [ $c->[3], $c->[1] + $c->[2] ]; - $count = 2; - # print STDERR "Special short circuit\n"; - } else { - @$c = @{$c}[$type eq "or" ? (3, 2, 1) : (3, 1, 2)]; - $count = 3; - } - # print STDERR "$type 3 $name [", join(",", @$c), "] $File:$Line\n"; - } elsif ($type eq "xor") { - # !l&&!r l&&!r l&&r !l&&r - @$c = @{$c}[3, 2, 4, 1]; - $count = 4; - } else { - die qq(Unknown type "$type" for conditional); - } + my $count; - my $structure = { - type => "${type}_${count}", - op => $strop, - left => $left, - right => $right, - }; - - my ($n, $new) = $Structure->add_count("condition"); - $Structure->add_condition($File, [ $Line, $structure ]) if $new; - my $ccount = $Run{count}{$File}; - if (exists $ccount->{condition}[$n]) { - $ccount->{condition}[$n][$_] += $c->[$_] for 0 .. $#$c; + if ($type eq "or" || $type eq "and") { + my $r = $op->first->sibling; + my $name = $r->name; + $name = $r->first->name if $name eq "sassign"; + # TODO - exec? any others? + # print STDERR "Name [$name]", Dumper $c; + if ($c->[5] || $name =~ $Const_right) { + $c = [ $c->[3], $c->[1] + $c->[2] ]; + $count = 2; + # print STDERR "Special short circuit\n"; } else { - $ccount->{condition}[$n] = $c; - my $vec = $Run{vec}{$File}{condition}; - vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; + @$c = @{$c}[ $type eq "or" ? (3, 2, 1) : (3, 1, 2) ]; + $count = 3; } + # print STDERR "$type 3 $name [", join(",", @$c), "] $File:$Line\n"; + } elsif ($type eq "xor") { + # !l&&!r l&&!r l&&r !l&&r + @$c = @{$c}[ 3, 2, 4, 1 ]; + $count = 4; + } else { + die qq(Unknown type "$type" for conditional); + } + + my $structure = { + type => "${type}_${count}", + op => $strop, + left => $left, + right => $right, + }; + + my ($n, $new) = $Structure->add_count("condition"); + $Structure->add_condition($File, [ $Line, $structure ]) if $new; + my $ccount = $Run{count}{$File}; + if (exists $ccount->{condition}[$n]) { + $ccount->{condition}[$n][$_] += $c->[$_] for 0 .. $#$c; + } else { + $ccount->{condition}[$n] = $c; + my $vec = $Run{vec}{$File}{condition}; + vec($vec->{vec}, $vec->{size}++, 1) = $_ ||= 0 ? 1 : 0 for @$c; + } } { - no warnings "once"; - *is_scope = \&B::Deparse::is_scope; - *is_state = \&B::Deparse::is_state; - *is_ifelse_cont = \&B::Deparse::is_ifelse_cont; + no warnings "once"; + *is_scope = \&B::Deparse::is_scope; + *is_state = \&B::Deparse::is_state; + *is_ifelse_cont = \&B::Deparse::is_ifelse_cont; } my %Original; { -BEGIN { + BEGIN { $Original{deparse} = \&B::Deparse::deparse; $Original{logop} = \&B::Deparse::logop; $Original{logassignop} = \&B::Deparse::logassignop; $Original{const_dumper} = \&B::Deparse::const_dumper; $Original{const} = \&B::Deparse::const if defined &B::Deparse::const; -} + } -sub const_dumper { + sub const_dumper { no warnings "redefine"; + local *B::Deparse::deparse = $Original{deparse}; local *B::Deparse::logop = $Original{logop}; local *B::Deparse::logassignop = $Original{logassignop}; local *B::Deparse::const_dumper = $Original{const_dumper}; local *B::Deparse::const = $Original{const} if $Original{const}; + $Original{const_dumper}->(@_); -} + } -sub const { + sub const { no warnings "redefine"; local *B::Deparse::deparse = $Original{deparse}; local *B::Deparse::logop = $Original{logop}; local *B::Deparse::logassignop = $Original{logassignop}; local *B::Deparse::const_dumper = $Original{const_dumper}; $Original{const}->(@_); -} + } -sub deparse { + sub deparse { my $self = shift; my ($op, $cx) = @_; my $deparse; if ($Collect) { - my $class = B::class($op); - my $null = $class eq "NULL"; - - my $name = $op->can("name") ? $op->name : "Unknown"; - - # print STDERR "$class:$name ($$op) at $File:$Line\n"; - # print STDERR "[$Seen{statement}{$$op}] [$Seen{other}{$$op}]\n"; - # use Carp "cluck"; cluck("from here"); - - return "" if $name eq "padrange"; - - unless ($Seen{statement}{$$op} || $Seen{other}{$$op}) { - # Collect everything under here - local ($File, $Line) = ($File, $Line); - # print STDERR "Collecting $$op under $File:$Line\n"; - no warnings "redefine"; - my $use_dumper = $class eq "SVOP" && $name eq "const"; - local $self->{use_dumper} = 1 if $use_dumper; - require Data::Dumper if $use_dumper; - $deparse = eval { local $^W; $Original{deparse}->($self, @_) }; - $deparse =~ s/^\010+//mg if defined $deparse; - $deparse = "Deparse error: $@" if $@; - # print STDERR "Collected $$op under $File:$Line\n"; - # print STDERR "Collect Deparse $op $$op => <$deparse>\n"; - } + my $class = B::class($op); + my $null = $class eq "NULL"; - # Get the coverage on this op - - if ($class eq "COP" && $Coverage{statement}) { - # print STDERR "COP $$op, seen [$Seen{statement}{$$op}]\n"; - my $nnnext = ""; - eval { - my $next = $op->next; - my $nnext = $next && $next->next; - $nnnext = $nnext && $nnext->next; - }; - # print STDERR "COP $$op, ", $next, " -> ", $nnext, - # " -> ", $nnnext, "\n"; - if ($nnnext) { - add_statement_cover($op) unless $Seen{statement}{$$op}++; - } - } elsif (!$null && $name eq "null" - && ppname($op->targ) eq "pp_nextstate" - && $Coverage{statement}) { - # If the current op is null, but it was nextstate, we can still - # get at the file and line number, but we need to get dirty - - bless $op, "B::COP"; - # print STDERR "null $$op, seen [$Seen{statement}{$$op}]\n"; - add_statement_cover($op) unless $Seen{statement}{$$op}++; - bless $op, "B::$class"; - } elsif ($Seen{other}{$$op}++) { - # print STDERR "seen [$Seen{other}{$$op}]\n"; - return "" # Only report on each op once - } elsif ($name eq "cond_expr") { - local ($File, $Line) = ($File, $Line); - my $cond = $op->first; - my $true = $cond->sibling; - my $false = $true->sibling; - if (!($cx < 1 && (is_scope($true) && $true->name ne "null") && - (is_scope($false) || is_ifelse_cont($false)) - && $self->{'expand'} < 7)) { - { local $Collect; $cond = $self->deparse($cond, 8) } - add_branch_cover($op, "if", "$cond ? :", $File, $Line); - } else { - { local $Collect; $cond = $self->deparse($cond, 1) } - add_branch_cover($op, "if", "if ($cond) { }", $File, $Line); - while (B::class($false) ne "NULL" && is_ifelse_cont($false)) { - my $newop = $false->first; - my $newcond = $newop->first; - my $newtrue = $newcond->sibling; - if ($newcond->name eq "lineseq") { - # lineseq to ensure correct line numbers in elsif() - # Bug #37302 fixed by change #33710 - $newcond = $newcond->first->sibling; - } - # last in chain is OP_AND => no else - $false = $newtrue->sibling; - { local $Collect; $newcond = $self->deparse($newcond, 1) } - add_branch_cover($newop, "elsif", "elsif ($newcond) { }", - $File, $Line); - } - } - } - } else { + my $name = $op->can("name") ? $op->name : "Unknown"; + + # print STDERR "$class:$name ($$op) at $File:$Line\n"; + # print STDERR "[$Seen{statement}{$$op}] [$Seen{other}{$$op}]\n"; + # use Carp "cluck"; cluck("from here"); + + return "" if $name eq "padrange"; + + unless ($Seen{statement}{$$op} || $Seen{other}{$$op}) { + # Collect everything under here local ($File, $Line) = ($File, $Line); - # print STDERR "Starting plain deparse at $File:$Line\n"; + # print STDERR "Collecting $$op under $File:$Line\n"; + no warnings "redefine"; + my $use_dumper = $class eq "SVOP" && $name eq "const"; + local $self->{use_dumper} = 1 if $use_dumper; + require Data::Dumper if $use_dumper; $deparse = eval { local $^W; $Original{deparse}->($self, @_) }; - $deparse = "" unless defined $deparse; - $deparse =~ s/^\010+//mg; + $deparse =~ s/^\010+//mg if defined $deparse; $deparse = "Deparse error: $@" if $@; - # print STDERR "Ending plain deparse at $File:$Line\n"; - # print STDERR "Deparse => <$deparse>\n"; + # print STDERR "Collected $$op under $File:$Line\n"; + # print STDERR "Collect Deparse $op $$op => <$deparse>\n"; + } + + # Get the coverage on this op + + if ($class eq "COP" && $Coverage{statement}) { + # print STDERR "COP $$op, seen [$Seen{statement}{$$op}]\n"; + my $nnnext = ""; + eval { + my $next = $op->next; + my $nnext = $next && $next->next; + $nnnext = $nnext && $nnext->next; + }; + # print STDERR "COP $$op, ", $next, " -> ", $nnext, + # " -> ", $nnnext, "\n"; + if ($nnnext) { + add_statement_cover($op) unless $Seen{statement}{$$op}++; + } + } elsif (!$null + && $name eq "null" + && ppname($op->targ) eq "pp_nextstate" + && $Coverage{statement}) + { + # If the current op is null, but it was nextstate, we can still + # get at the file and line number, but we need to get dirty + + bless $op, "B::COP"; + # print STDERR "null $$op, seen [$Seen{statement}{$$op}]\n"; + add_statement_cover($op) unless $Seen{statement}{$$op}++; + bless $op, "B::$class"; + } elsif ($Seen{other}{$$op}++) { + # print STDERR "seen [$Seen{other}{$$op}]\n"; + return "" # Only report on each op once + } elsif ($name eq "cond_expr") { + local ($File, $Line) = ($File, $Line); + my $cond = $op->first; + my $true = $cond->sibling; + my $false = $true->sibling; + if (!( + $cx < 1 + && (is_scope($true) && $true->name ne "null") + && (is_scope($false) || is_ifelse_cont($false)) + && $self->{'expand'} < 7 + )) + { + { local $Collect; $cond = $self->deparse($cond, 8) } + add_branch_cover($op, "if", "$cond ? :", $File, $Line); + } else { + { local $Collect; $cond = $self->deparse($cond, 1) } + add_branch_cover($op, "if", "if ($cond) { }", $File, $Line); + while (B::class($false) ne "NULL" && is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + if ($newcond->name eq "lineseq") { + # lineseq to ensure correct line numbers in elsif() + # Bug #37302 fixed by change #33710 + $newcond = $newcond->first->sibling; + } + # last in chain is OP_AND => no else + $false = $newtrue->sibling; + { local $Collect; $newcond = $self->deparse($newcond, 1) } + add_branch_cover($newop, "elsif", "elsif ($newcond) { }", + $File, $Line); + } + } + } + } else { + local ($File, $Line) = ($File, $Line); + # print STDERR "Starting plain deparse at $File:$Line\n"; + $deparse = eval { local $^W; $Original{deparse}->($self, @_) }; + $deparse = "" unless defined $deparse; + $deparse =~ s/^\010+//mg; + $deparse = "Deparse error: $@" if $@; + # print STDERR "Ending plain deparse at $File:$Line\n"; + # print STDERR "Deparse => <$deparse>\n"; } # print STDERR "Returning [$deparse]\n"; $deparse -} + } -sub logop { + sub logop { my $self = shift; my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; my $left = $op->first; @@ -1117,195 +1127,196 @@ sub logop { my ($file, $line) = ($File, $Line); if ($cx < 1 && is_scope($right) && $blockname && $self->{expand} < 7) { - # print STDERR 'if ($a) {$b}', "\n"; - # if ($a) {$b} - $left = $self->deparse($left, 1); - $right = $self->deparse($right, 0); - add_branch_cover($op, $lowop, "$blockname ($left)", $file, $line) - unless $Seen{branch}{$$op}++; - return "$blockname ($left) {\n\t$right\n\b}\cK" + # print STDERR 'if ($a) {$b}', "\n"; + # if ($a) {$b} + $left = $self->deparse($left, 1); + $right = $self->deparse($right, 0); + add_branch_cover($op, $lowop, "$blockname ($left)", $file, $line) + unless $Seen{branch}{$$op}++; + return "$blockname ($left) {\n\t$right\n\b}\cK" } elsif ($cx < 1 && $blockname && !$self->{parens} && $self->{expand} < 7) { - # print STDERR '$b if $a', "\n"; - # $b if $a - $right = $self->deparse($right, 1); - $left = $self->deparse($left, 1); - add_branch_cover($op, $lowop, "$blockname $left", $file, $line) - unless $Seen{branch}{$$op}++; - return "$right $blockname $left" + # print STDERR '$b if $a', "\n"; + # $b if $a + $right = $self->deparse($right, 1); + $left = $self->deparse($left, 1); + add_branch_cover($op, $lowop, "$blockname $left", $file, $line) + unless $Seen{branch}{$$op}++; + return "$right $blockname $left" } elsif ($cx > $lowprec && $highop) { - # print STDERR '$a && $b', "\n"; - # $a && $b - { - local $Collect; - $left = $self->deparse_binop_left ($op, $left, $highprec); - $right = $self->deparse_binop_right($op, $right, $highprec); - } - # print STDERR "left [$left], right [$right]\n"; - add_condition_cover($op, $highop, $left, $right) - unless $Seen{condition}{$$op}++; - return $self->maybe_parens("$left $highop $right", $cx, $highprec) + # print STDERR '$a && $b', "\n"; + # $a && $b + { + local $Collect; + $left = $self->deparse_binop_left($op, $left, $highprec); + $right = $self->deparse_binop_right($op, $right, $highprec); + } + # print STDERR "left [$left], right [$right]\n"; + add_condition_cover($op, $highop, $left, $right) + unless $Seen{condition}{$$op}++; + return $self->maybe_parens("$left $highop $right", $cx, $highprec) } else { - # print STDERR '$a and $b', "\n"; - # $a and $b - $left = $self->deparse_binop_left ($op, $left, $lowprec); - $right = $self->deparse_binop_right($op, $right, $lowprec); - add_condition_cover($op, $lowop, $left, $right) - unless $Seen{condition}{$$op}++; - return $self->maybe_parens("$left $lowop $right", $cx, $lowprec) + # print STDERR '$a and $b', "\n"; + # $a and $b + $left = $self->deparse_binop_left($op, $left, $lowprec); + $right = $self->deparse_binop_right($op, $right, $lowprec); + add_condition_cover($op, $lowop, $left, $right) + unless $Seen{condition}{$$op}++; + return $self->maybe_parens("$left $lowop $right", $cx, $lowprec) } -} + } -sub logassignop { + sub logassignop { my $self = shift; my ($op, $cx, $opname) = @_; - my $left = $op->first; + my $left = $op->first; my $right = $op->first->sibling->first; # skip sassign - $left = $self->deparse($left, 7); + $left = $self->deparse($left, 7); $right = $self->deparse($right, 7); add_condition_cover($op, $opname, $left, $right); return $self->maybe_parens("$left $opname $right", $cx, 7); -} + } } sub get_cover { - my $deparse = B::Deparse->new; + my $deparse = B::Deparse->new; - my $cv = $deparse->{curcv} = shift; + my $cv = $deparse->{curcv} = shift; - ($Sub_name, my $start) = sub_info($cv); + ($Sub_name, my $start) = sub_info($cv); - # warn "get_cover: <$Sub_name>\n"; - return unless defined $Sub_name; # Only happens within Safe.pm, AFAIK + # warn "get_cover: <$Sub_name>\n"; + return unless defined $Sub_name; # Only happens within Safe.pm, AFAIK # return unless length $Sub_name; # Only happens with Self_cover, AFAIK - get_location($start) if $start; - # print STDERR "[[$File:$Line]]\n"; - # return unless length $File; - return if length $File && !use_file($File); + get_location($start) if $start; + # print STDERR "[[$File:$Line]]\n"; + # return unless length $File; + return if length $File && !use_file($File); - return if !$Self_cover_run && $File =~ /Devel\/Cover/; - return if $Self_cover_run && $File !~ /Devel\/Cover/; - return if $Self_cover_run && - $File =~ /Devel\/Cover\.pm$/ && - $Sub_name eq "import"; + return if !$Self_cover_run && $File =~ /Devel\/Cover/; + return if $Self_cover_run && $File !~ /Devel\/Cover/; + return + if $Self_cover_run && $File =~ /Devel\/Cover\.pm$/ && $Sub_name eq "import"; - # printf STDERR "getting cover for $Sub_name ($start), %x\n", $$cv; + # printf STDERR "getting cover for $Sub_name ($start), %x\n", $$cv; - if ($start) { - no warnings "uninitialized"; - if ($File eq $Structure->get_file && $Line == $Structure->get_line && - $Sub_name eq "__ANON__" && $Structure->get_sub_name eq "__ANON__") { - # Merge instances of anonymous subs into one - # TODO - multiple anonymous subs on the same line - } else { - my $count = $Sub_count->{$File}{$Line}{$Sub_name}++; - $Structure->set_subroutine($Sub_name, $File, $Line, $count); - add_subroutine_cover($start) - if $Coverage{subroutine} || $Coverage{pod}; # pod requires subs - } + if ($start) { + no warnings "uninitialized"; + if ( $File eq $Structure->get_file + && $Line == $Structure->get_line + && $Sub_name eq "__ANON__" + && $Structure->get_sub_name eq "__ANON__") + { + # Merge instances of anonymous subs into one + # TODO - multiple anonymous subs on the same line + } else { + my $count = $Sub_count->{$File}{$Line}{$Sub_name}++; + $Structure->set_subroutine($Sub_name, $File, $Line, $count); + add_subroutine_cover($start) + if $Coverage{subroutine} || $Coverage{pod}; # pod requires subs } + } - if ($Pod && $Coverage{pod}) { - my $gv = $cv->GV; - if ($gv && !$gv->isa("B::SPECIAL")) { - my $stash = $gv->STASH; - my $pkg = $stash->NAME; - my $file = $cv->FILE; - my %opts; - $Run{digests}{$File} ||= $Structure->set_file($File); - if (ref $Coverage_options{pod}) { - my $p; - for (@{$Coverage_options{pod}}) { - if (/^package|(?:also_)?private|trustme|pod_from|nocp$/) { - $opts{$p = $_} = []; - } elsif ($p) { - push @{$opts{$p}}, $_; - } - } - for $p (qw( private also_private trustme )) { - next unless exists $opts{$p}; - $_ = qr/$_/ for @{$opts{$p}}; - } - } - $Pod = "Pod::Coverage" if delete $opts{nocp}; - # print STDERR "$Pod, $File:$Line ($Sub_name) [$file($pkg)]", - # Dumper \%opts; - if ($Pod{$pkg} ||= $Pod->new(package => $pkg, %opts)) { - # print STDERR Dumper $Pod{$file}; - my $covered; - for ($Pod{$pkg}->covered) { - $covered = 1, last if $_ eq $Sub_name; - } - unless ($covered) { - for ($Pod{$pkg}->uncovered) { - $covered = 0, last if $_ eq $Sub_name; - } - } - # print STDERR "covered ", $covered // "undef", "\n"; - if (defined $covered) { - my ($n, $new) = $Structure->add_count("pod"); - $Structure->add_pod($File, [ $Line, $Sub_name ]) if $new; - $Run{count}{$File}{pod}[$n] += $covered; - my $vec = $Run{vec}{$File}{pod}; - vec($vec->{vec}, $n, 1) = $covered ? 1 : 0; - $vec->{size} = $n + 1; - } - } + if ($Pod && $Coverage{pod}) { + my $gv = $cv->GV; + if ($gv && !$gv->isa("B::SPECIAL")) { + my $stash = $gv->STASH; + my $pkg = $stash->NAME; + my $file = $cv->FILE; + my %opts; + $Run{digests}{$File} ||= $Structure->set_file($File); + if (ref $Coverage_options{pod}) { + my $p; + for (@{ $Coverage_options{pod} }) { + if (/^package|(?:also_)?private|trustme|pod_from|nocp$/) { + $opts{ $p = $_ } = []; + } elsif ($p) { + push @{ $opts{$p} }, $_; + } } + for $p (qw( private also_private trustme )) { + next unless exists $opts{$p}; + $_ = qr/$_/ for @{ $opts{$p} }; + } + } + $Pod = "Pod::Coverage" if delete $opts{nocp}; + # print STDERR "$Pod, $File:$Line ($Sub_name) [$file($pkg)]", + # Dumper \%opts; + if ($Pod{$pkg} ||= $Pod->new(package => $pkg, %opts)) { + # print STDERR Dumper $Pod{$file}; + my $covered; + for ($Pod{$pkg}->covered) { + $covered = 1, last if $_ eq $Sub_name; + } + unless ($covered) { + for ($Pod{$pkg}->uncovered) { + $covered = 0, last if $_ eq $Sub_name; + } + } + # print STDERR "covered ", $covered // "undef", "\n"; + if (defined $covered) { + my ($n, $new) = $Structure->add_count("pod"); + $Structure->add_pod($File, [ $Line, $Sub_name ]) if $new; + $Run{count}{$File}{pod}[$n] += $covered; + my $vec = $Run{vec}{$File}{pod}; + vec($vec->{vec}, $n, 1) = $covered ? 1 : 0; + $vec->{size} = $n + 1; + } + } } + } - # my $dd = @_ && ref $_[0] - # ? $deparse->deparse($_[0], 0) - # : $deparse->deparse_sub($cv, 0); - # print STDERR "get_cover: <$Sub_name>\n"; - # print STDERR "[[$File:$Line]]\n"; - # print STDERR "<$dd>\n"; + # my $dd = @_ && ref $_[0] + # ? $deparse->deparse($_[0], 0) + # : $deparse->deparse_sub($cv, 0); + # print STDERR "get_cover: <$Sub_name>\n"; + # print STDERR "[[$File:$Line]]\n"; + # print STDERR "<$dd>\n"; - no warnings "redefine"; - local *B::Deparse::deparse = \&deparse; - local *B::Deparse::logop = \&logop; - local *B::Deparse::logassignop = \&logassignop; - local *B::Deparse::const_dumper = \&const_dumper; - local *B::Deparse::const = \&const if $Original{const}; - - my $de = @_ && ref $_[0] - ? $deparse->deparse($_[0], 0) - : $deparse->deparse_sub($cv, 0); - # print STDERR "<$de>\n"; - $de + no warnings "redefine"; + + local *B::Deparse::deparse = \&deparse; + local *B::Deparse::logop = \&logop; + local *B::Deparse::logassignop = \&logassignop; + local *B::Deparse::const_dumper = \&const_dumper; + local *B::Deparse::const = \&const if $Original{const}; + + my $de = @_ + && ref $_[0] ? $deparse->deparse($_[0], 0) : $deparse->deparse_sub($cv, 0); + + # print STDERR "<$de>\n"; + $de } sub _report_progress { - my ($msg, $code, @items) = @_; - if ($Silent) { - $code->($_) for @items; - return; - } - my $tot = @items || 1; - my $prog = sub { - my ($n) = @_; - print OUT "\r" . __PACKAGE__ . ": " . int(100 * $n / $tot) . "% "; - }; - my ($old_pipe, $n, $start) = ($|, 0, time); - $|++; - print OUT __PACKAGE__, ": $msg\n"; - my $is_interactive = -t *OUT; - for (@items) { - $prog->($n++) - if $is_interactive; - $code->($_); - } - $prog->($n || 1); - print OUT __PACKAGE__ . ": Done " - if !$is_interactive; - print OUT "- " . (time - $start) . "s taken\n"; - $| = $old_pipe; + my ($msg, $code, @items) = @_; + if ($Silent) { + $code->($_) for @items; + return; + } + my $tot = @items || 1; + my $prog = sub { + my ($n) = @_; + print OUT "\r" . __PACKAGE__ . ": " . int(100 * $n / $tot) . "% "; + }; + my ($old_pipe, $n, $start) = ($|, 0, time); + $|++; + print OUT __PACKAGE__, ": $msg\n"; + my $is_interactive = -t *OUT; + for (@items) { + $prog->($n++) if $is_interactive; + $code->($_); + } + $prog->($n || 1); + print OUT __PACKAGE__ . ": Done " if !$is_interactive; + print OUT "- " . (time - $start) . "s taken\n"; + $| = $old_pipe; } sub get_cover_progress { - my ($type, @cvs) = @_; - _report_progress("getting $type coverage", sub { get_cover($_) }, @cvs); + my ($type, @cvs) = @_; + _report_progress("getting $type coverage", sub { get_cover($_) }, @cvs); } " @@ -1845,7 +1856,7 @@ Please report new bugs on Github. =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Annotation/Git.pm b/lib/Devel/Cover/Annotation/Git.pm index ed10b716..85e2378e 100644 --- a/lib/Devel/Cover/Annotation/Git.pm +++ b/lib/Devel/Cover/Annotation/Git.pm @@ -1,4 +1,4 @@ -# Copyright 2005-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2005-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -15,100 +15,99 @@ use warnings; use Getopt::Long; sub new { - my $class = shift; - my $annotate_arg = $ENV{DEVEL_COVER_GIT_ANNOTATE} || ""; - my $self = { - annotations => [ qw( version author date ) ], - command => "git blame --porcelain $annotate_arg [[file]]", - @_ - }; - - bless $self, $class + my $class = shift; + my $annotate_arg = $ENV{DEVEL_COVER_GIT_ANNOTATE} || ""; + my $self = { + annotations => [qw( version author date )], + command => "git blame --porcelain $annotate_arg [[file]]", + @_, + }; + + bless $self, $class } sub get_annotations { - my $self = shift; - my ($file) = @_; - - return if exists $self->{_annotations}{$file}; - my $annotations = $self->{_annotations}{$file} = []; - - print "cover: Getting git annotation information for $file\n"; - - my $command = $self->{command}; - $command =~ s/\[\[file\]\]/$file/g; - # print "Running [$command]\n"; - open my $c, "-|", $command - or warn("cover: Can't run $command: $!\n"), return; - my @annotaiton; - my $start = 1; - while (my $line = <$c>) { - # print "[$_]\n"; - if ($line =~ /^\t/) { - push @$annotations, [@annotaiton]; - $start = 1; - next; - } - - if ($start == 1) { - $annotaiton[0] = substr $1, 0, 8 if /$line =~ ^(\w+)/; - $start = 0; - } else { - $annotaiton[1] = $1 if $line =~ /^author (.*)/; - $annotaiton[2] = localtime $1 if $line =~ /^author-time (.*)/; - } + my $self = shift; + my ($file) = @_; + + return if exists $self->{_annotations}{$file}; + my $annotations = $self->{_annotations}{$file} = []; + + print "cover: Getting git annotation information for $file\n"; + + my $command = $self->{command}; + $command =~ s/\[\[file\]\]/$file/g; + # print "Running [$command]\n"; + open my $c, "-|", $command or warn("cover: Can't run $command: $!\n"), return; + my @annotaiton; + my $start = 1; + while (my $line = <$c>) { + # print "[$_]\n"; + if ($line =~ /^\t/) { + push @$annotations, [@annotaiton]; + $start = 1; + next; } - close $c or warn "cover: Failed running $command: $!\n" + + if ($start == 1) { + $annotaiton[0] = substr $1, 0, 8 if /$line =~ ^(\w+)/; + $start = 0; + } else { + $annotaiton[1] = $1 if $line =~ /^author (.*)/; + $annotaiton[2] = localtime $1 if $line =~ /^author-time (.*)/; + } + } + close $c or warn "cover: Failed running $command: $!\n" } sub get_options { - my ($self, $opt) = @_; - $self->{$_} = 1 for @{$self->{annotations}}; - die "Bad option" unless - GetOptions($self, - qw( - author - command=s - date - version - )); + my ($self, $opt) = @_; + $self->{$_} = 1 for @{ $self->{annotations} }; + die "Bad option" unless GetOptions( + $self, qw( + author + command=s + date + version + ) + ); } sub count { - my $self = shift; - $self->{author} + $self->{date} + $self->{version} + my $self = shift; + $self->{author} + $self->{date} + $self->{version} } sub header { - my $self = shift; - my ($annotation) = @_; - $self->{annotations}[$annotation] + my $self = shift; + my ($annotation) = @_; + $self->{annotations}[$annotation] } sub width { - my $self = shift; - my ($annotation) = @_; - (8, 16, 24)[$annotation] + my $self = shift; + my ($annotation) = @_; + (8, 16, 24)[$annotation] } sub text { - my $self = shift; - my ($file, $line, $annotation) = @_; - return "" unless $line; - $self->get_annotations($file); - $self->{_annotations}{$file}[$line - 1][$annotation] + my $self = shift; + my ($file, $line, $annotation) = @_; + return "" unless $line; + $self->get_annotations($file); + $self->{_annotations}{$file}[ $line - 1 ][$annotation] } sub error { - my $self = shift; - my ($file, $line, $annotation) = @_; - 0 + my $self = shift; + my ($file, $line, $annotation) = @_; + 0 } sub class { - my $self = shift; - my ($file, $line, $annotation) = @_; - "" + my $self = shift; + my ($file, $line, $annotation) = @_; + "" } 1 @@ -138,7 +137,7 @@ Huh? =head1 LICENCE -Copyright 2005-2023, Paul Johnson (paul@pjcj.net) +Copyright 2005-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Annotation/Random.pm b/lib/Devel/Cover/Annotation/Random.pm index 47ece49c..c62a9469 100644 --- a/lib/Devel/Cover/Annotation/Random.pm +++ b/lib/Devel/Cover/Annotation/Random.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -15,57 +15,57 @@ use warnings; use Getopt::Long; sub new { - my $class = shift; - bless {@_}, $class + my $class = shift; + bless {@_}, $class } sub get_options { - my ($self, $opt) = @_; - $self->{count} = 1; - die "Bad option" unless - GetOptions($self, - qw( - count=s - )); + my ($self, $opt) = @_; + $self->{count} = 1; + die "Bad option" unless GetOptions( + $self, qw( + count=s + ) + ); } sub count { - my $self = shift; - $self->{count} + my $self = shift; + $self->{count} } sub header { - my $self = shift; - my ($annotation) = @_; - "rnd$annotation" + my $self = shift; + my ($annotation) = @_; + "rnd$annotation" } sub width { - my $self = shift; - my ($annotation) = @_; - length $self->header($annotation) + my $self = shift; + my ($annotation) = @_; + length $self->header($annotation) } sub text { - my $self = shift; - my ($file, $line, $annotation) = @_; - return "" unless $line; - $self->{annotation}{$file}[$line][$annotation] = int rand 10 - unless defined $self->{annotation}{$file}[$line][$annotation]; - $self->{annotation}{$file}[$line][$annotation] + my $self = shift; + my ($file, $line, $annotation) = @_; + return "" unless $line; + $self->{annotation}{$file}[$line][$annotation] = int rand 10 + unless defined $self->{annotation}{$file}[$line][$annotation]; + $self->{annotation}{$file}[$line][$annotation] } sub error { - my $self = shift; - my ($file, $line, $annotation) = @_; - !$self->text($file, $line, $annotation) + my $self = shift; + my ($file, $line, $annotation) = @_; + !$self->text($file, $line, $annotation) } sub class { - my $self = shift; - my ($file, $line, $annotation) = @_; - return "" unless $line; - "c" . int(($self->text($file, $line, $annotation) + 2) / 3) + my $self = shift; + my ($file, $line, $annotation) = @_; + return "" unless $line; + "c" . int(($self->text($file, $line, $annotation) + 2) / 3) } 1 @@ -95,7 +95,7 @@ Huh? =head1 LICENCE -Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +Copyright 2004-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Annotation/Svk.pm b/lib/Devel/Cover/Annotation/Svk.pm index 678b62f1..5958e5c1 100644 --- a/lib/Devel/Cover/Annotation/Svk.pm +++ b/lib/Devel/Cover/Annotation/Svk.pm @@ -1,4 +1,4 @@ -# Copyright 2005-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2005-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -16,122 +16,122 @@ use Getopt::Long; use Digest::MD5; sub md5_fh { - my $fh = shift; - my $ctx = Digest::MD5->new; - $ctx->addfile($fh); - $ctx->hexdigest + my $fh = shift; + my $ctx = Digest::MD5->new; + $ctx->addfile($fh); + $ctx->hexdigest } sub new { - my $class = shift; - my $annotate_arg = $ENV{DEVEL_COVER_SVK_ANNOTATE} || ""; - my $self = { - annotations => [ qw( version author date ) ], - command => "svk annotate $annotate_arg [[file]]", - @_ - }; - - bless $self, $class; - - open my $c, "-|", "svk info" - or warn("cover: Not a svk checkout: $!\n"), return; - while (<$c>) { - chomp; - next unless s/^Depot Path: //; - $self->{depotbase} = $_; - last; - } - - open $c, "-|", "svk ls -Rf $self->{depotbase}" - or warn("cover: Can't run svk ls: $!\n"), return; - while (<$c>) { - chomp; - s|^\Q$self->{depotbase}\E/||; - next unless -f $_; - - open my $f, $_ or warn("cover: Can't open $_: $!\n"), next; - $self->{md5map}{md5_fh($f)} = $_; - } - - $self + my $class = shift; + my $annotate_arg = $ENV{DEVEL_COVER_SVK_ANNOTATE} || ""; + my $self = { + annotations => [qw( version author date )], + command => "svk annotate $annotate_arg [[file]]", + @_, + }; + + bless $self, $class; + + open my $c, "-|", "svk info" + or warn("cover: Not a svk checkout: $!\n"), return; + while (<$c>) { + chomp; + next unless s/^Depot Path: //; + $self->{depotbase} = $_; + last; + } + + open $c, "-|", "svk ls -Rf $self->{depotbase}" + or warn("cover: Can't run svk ls: $!\n"), return; + while (<$c>) { + chomp; + s|^\Q$self->{depotbase}\E/||; + next unless -f $_; + + open my $f, $_ or warn("cover: Can't open $_: $!\n"), next; + $self->{md5map}{ md5_fh($f) } = $_; + } + + $self } sub get_annotations { - my $self = shift; - my ($file) = @_; - - return if exists $self->{_annotations}{$file}; - my $a = $self->{_annotations}{$file} = []; - - print "cover: Getting svk annotation information for $file\n"; - - open my $fh, $file or warn("cover: Can't open file $file: $!\n"), return; - my $realfile = $self->{md5map}{md5_fh($fh)} - or warn("cover: $file is not under svk control\n"), return; - - my $command = $self->{command}; - $command =~ s/\[\[file\]\]/$realfile/g; - open my $c, "-|", $command - or warn("cover: Can't run $command: $!\n"), return; - <$c>; <$c>; # ignore first two lines - while (<$c>) { - my @a = /(\d+)\s*\(\s*(\S+)\s*(.*?)\):/; - # hack for linking the revision number - $a[0] = qq|$a[0]| - if $ENV{SVNWEB_URL}; - push @$a, \@a; - } - close $c or warn "cover: Failed running $command: $!\n" + my $self = shift; + my ($file) = @_; + + return if exists $self->{_annotations}{$file}; + my $a = $self->{_annotations}{$file} = []; + + print "cover: Getting svk annotation information for $file\n"; + + open my $fh, $file or warn("cover: Can't open file $file: $!\n"), return; + my $realfile = $self->{md5map}{ md5_fh($fh) } + or warn("cover: $file is not under svk control\n"), return; + + my $command = $self->{command}; + $command =~ s/\[\[file\]\]/$realfile/g; + open my $c, "-|", $command or warn("cover: Can't run $command: $!\n"), return; + <$c>; + <$c>; # ignore first two lines + while (<$c>) { + my @a = /(\d+)\s*\(\s*(\S+)\s*(.*?)\):/; + # hack for linking the revision number + $a[0] = qq|$a[0]| + if $ENV{SVNWEB_URL}; + push @$a, \@a; + } + close $c or warn "cover: Failed running $command: $!\n" } sub get_options { - my ($self, $opt) = @_; - $self->{$_} = 1 for @{$self->{annotations}}; - die "Bad option" unless - GetOptions($self, - qw( - author - command=s - date - version - )); + my ($self, $opt) = @_; + $self->{$_} = 1 for @{ $self->{annotations} }; + die "Bad option" unless GetOptions( + $self, qw( + author + command=s + date + version + ) + ); } sub count { - my $self = shift; - $self->{author} + $self->{date} + $self->{version} + my $self = shift; + $self->{author} + $self->{date} + $self->{version} } sub header { - my $self = shift; - my ($annotation) = @_; - $self->{annotations}[$annotation] + my $self = shift; + my ($annotation) = @_; + $self->{annotations}[$annotation] } sub width { - my $self = shift; - my ($annotation) = @_; - (7, 10, 10)[$annotation] + my $self = shift; + my ($annotation) = @_; + (7, 10, 10)[$annotation] } sub text { - my $self = shift; - my ($file, $line, $annotation) = @_; - return "" unless $line; - $self->get_annotations($file); - $self->{_annotations}{$file}[$line - 1][$annotation] + my $self = shift; + my ($file, $line, $annotation) = @_; + return "" unless $line; + $self->get_annotations($file); + $self->{_annotations}{$file}[ $line - 1 ][$annotation] } sub error { - my $self = shift; - my ($file, $line, $annotation) = @_; - 0 + my $self = shift; + my ($file, $line, $annotation) = @_; + 0 } sub class { - my $self = shift; - my ($file, $line, $annotation) = @_; - "" + my $self = shift; + my ($file, $line, $annotation) = @_; + "" } 1 @@ -161,7 +161,7 @@ Huh? =head1 LICENCE -Copyright 2005-2023, Paul Johnson (paul@pjcj.net) +Copyright 2005-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Branch.pm b/lib/Devel/Cover/Branch.pm index 64a337ca..00b2c0cc 100644 --- a/lib/Devel/Cover/Branch.pm +++ b/lib/Devel/Cover/Branch.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -14,45 +14,47 @@ use warnings; use base "Devel::Cover::Criterion"; -sub pad { my $self = shift; $self->[0] = [0, 0] - unless $self->[0] && @{$self->[0]}; } -sub uncoverable { @_ > 1 ? $_[0][2][$_[1]] : scalar grep $_, @{$_[0][2]} } -sub covered { @_ > 1 ? $_[0][0][$_[1]] : scalar grep $_, @{$_[0][0]} } -sub total { scalar @{$_[0][0]} } -sub value { $_[0][0][$_[1]] } -sub values { @{$_[0][0]} } -sub text { $_[0][1]{text} } -sub criterion { "branch" } +sub pad { + my $self = shift; + $self->[0] = [ 0, 0 ] unless $self->[0] && @{ $self->[0] }; +} +sub uncoverable { @_ > 1 ? $_[0][2][ $_[1] ] : scalar grep $_, @{ $_[0][2] } } +sub covered { @_ > 1 ? $_[0][0][ $_[1] ] : scalar grep $_, @{ $_[0][0] } } +sub total { scalar @{ $_[0][0] } } +sub value { $_[0][0][ $_[1] ] } +sub values { @{ $_[0][0] } } +sub text { $_[0][1]{text} } +sub criterion { "branch" } sub percentage { - my $t = $_[0]->total; - sprintf "%3d", $t ? $_[0]->covered / $t * 100 : 0 + my $t = $_[0]->total; + sprintf "%3d", $t ? $_[0]->covered / $t * 100 : 0 } sub error { - my $self = shift; - if (@_) { - my $c = shift; - return $self->err_chk($self->covered($c), $self->uncoverable($c)); - } - my $e = 0; - for my $c (0 .. $#{$self->[0]}) { - $e++ if $self->err_chk($self->covered($c), $self->uncoverable($c)); - } - $e + my $self = shift; + if (@_) { + my $c = shift; + return $self->err_chk($self->covered($c), $self->uncoverable($c)); + } + my $e = 0; + for my $c (0 .. $#{ $self->[0] }) { + $e++ if $self->err_chk($self->covered($c), $self->uncoverable($c)); + } + $e } sub calculate_summary { - my $self = shift; - my ($db, $file) = @_; + my $self = shift; + my ($db, $file) = @_; - my $s = $db->{summary}; - $self->pad; + my $s = $db->{summary}; + $self->pad; - $self->aggregate($s, $file, "total", $self->total ); - $self->aggregate($s, $file, "uncoverable", $self->uncoverable); - $self->aggregate($s, $file, "covered", $self->covered ); - $self->aggregate($s, $file, "error", $self->error ); + $self->aggregate($s, $file, "total", $self->total); + $self->aggregate($s, $file, "uncoverable", $self->uncoverable); + $self->aggregate($s, $file, "covered", $self->covered); + $self->aggregate($s, $file, "error", $self->error); } 1 @@ -83,7 +85,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Collection.pm b/lib/Devel/Cover/Collection.pm index e25134fd..844a387d 100644 --- a/lib/Devel/Cover/Collection.pm +++ b/lib/Devel/Cover/Collection.pm @@ -1,4 +1,4 @@ -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -18,9 +18,9 @@ use Devel::Cover::Dumper; use JSON::MaybeXS (); use Parallel::Iterator "iterate_as_array"; -use POSIX "setsid"; +use POSIX "setsid"; use Template; -use Time::HiRes "time"; +use Time::HiRes "time"; use Class::XSAccessor (); use Moo; @@ -28,587 +28,576 @@ use namespace::clean; use warnings FATAL => "all"; # be explicit since Moo sets this my %A = ( - ro => [ qw( bin_dir cpancover_dir cpan_dir results_dir dryrun force - output_file report timeout verbose workers docker local ) ], - rwp => [ qw( build_dirs local_timeout modules module_file ) ], - rw => [ qw( ) ], + ro => [ qw( bin_dir cpancover_dir cpan_dir results_dir dryrun force + output_file report timeout verbose workers docker local ) ], + rwp => [qw( build_dirs local_timeout modules module_file )], + rw => [qw( )], ); while (my ($type, $names) = each %A) { has $_ => (is => $type) for @$names } sub BUILDARGS { - my $class = shift; - my (%args) = @_; - { - build_dirs => [], - cpan_dir => [grep -d, glob("~/.cpan ~/.local/share/.cpan")], - docker => "docker", - dryrun => 0, - force => 0, - local => 0, - local_timeout => 0, - modules => [], - output_file => "index.html", - report => "html_basic", - timeout => 1800, # half an hour - verbose => 0, - workers => 0, - %args, - } -}; + my $class = shift; + my (%args) = @_; + { + build_dirs => [], + cpan_dir => [ grep -d, glob("~/.cpan ~/.local/share/.cpan") ], + docker => "docker", + dryrun => 0, + force => 0, + local => 0, + local_timeout => 0, + modules => [], + output_file => "index.html", + report => "html_basic", + timeout => 1800, # half an hour + verbose => 0, + workers => 0, + %args, + } +} # display $non_buffered characters, then buffer sub _sys { - my $self = shift; - my ($non_buffered, @command) = @_; - # system @command; return "."; - my ($output1, $output2) = ("", ""); - $output1 = "dc -> @command\n" if $self->verbose; - my $timeout = $self->local_timeout || $self->timeout || 30 * 60; - my $max = 4e4; - # say "Setting alarm for $timeout seconds"; - my $ok = 0; - my $pid; - eval { - open STDIN, "<", "/dev/null" or die "Can't read /dev/null: $!"; - $pid = open my $fh, "-|" // die "Can't fork: $!"; - if ($pid) { - my $printed = 0; - local $SIG{ALRM} = sub { die "alarm\n" }; - alarm $timeout; - while (<$fh>) { - # print "got: $_"; - # say "printed $printed of $non_buffered"; - if ($printed < $non_buffered) { - print; - if (($printed += length) >= $non_buffered) { - say "Devel::Cover: buffering ..."; - } - } elsif (length $output2) { - $output2 = substr $output2 . $_, $max * -.1, $max * .1; - } else { - $output1 .= $_; - if (length $output1 > $max * .9) { - $output1 = substr $output1, 0, $max * .9; - $output2 = "\n"; - } - } - } - alarm 0; - if (close $fh) { - $ok = 1; - } else { - warn "Error running @command\n"; - } + my $self = shift; + my ($non_buffered, @command) = @_; + # system @command; return "."; + my ($output1, $output2) = ("", ""); + $output1 = "dc -> @command\n" if $self->verbose; + my $timeout = $self->local_timeout || $self->timeout || 30 * 60; + my $max = 4e4; + # say "Setting alarm for $timeout seconds"; + my $ok = 0; + my $pid; + eval { + open STDIN, "<", "/dev/null" or die "Can't read /dev/null: $!"; + $pid = open my $fh, "-|" // die "Can't fork: $!"; + if ($pid) { + my $printed = 0; + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm $timeout; + while (<$fh>) { + # print "got: $_"; + # say "printed $printed of $non_buffered"; + if ($printed < $non_buffered) { + print; + if (($printed += length) >= $non_buffered) { + say "Devel::Cover: buffering ..."; + } + } elsif (length $output2) { + $output2 = substr $output2 . $_, $max * -.1, $max * .1; } else { - setsid() != -1 or die "Can't start a new session: $!"; - open STDERR, ">&STDOUT" or die "Can't dup stdout: $!"; - exec @command or die "Can't exec @command: $!"; + $output1 .= $_; + if (length $output1 > $max * .9) { + $output1 = substr $output1, 0, $max * .9; + $output2 = "\n"; + } } - }; - if ($@) { - $ok = 0; - die "$@" unless $@ eq "alarm\n"; # propagate unexpected errs - warn "Timed out after $timeout seconds!\n"; - my $pgrp = getpgrp($pid); - my $n = kill "-KILL", $pgrp; - warn "killed $n processes"; + } + alarm 0; + if (close $fh) { + $ok = 1; + } else { + warn "Error running @command\n"; + } + } else { + setsid() != -1 or die "Can't start a new session: $!"; + open STDERR, ">&STDOUT" or die "Can't dup stdout: $!"; + exec @command or die "Can't exec @command: $!"; } - $ok ? length $output2 ? "$output1\n...\n$output2" : $output1 : undef -} - -sub sys { my ($s, @a) = @_; $s->_sys(4e4, @a) // "" } -sub bsys { my ($s, @a) = @_; $s->_sys(0, @a) // "" } + }; + if ($@) { + $ok = 0; + die "$@" unless $@ eq "alarm\n"; # propagate unexpected errs + warn "Timed out after $timeout seconds!\n"; + my $pgrp = getpgrp($pid); + my $n = kill "-KILL", $pgrp; + warn "killed $n processes"; + } + $ok ? length $output2 ? "$output1\n...\n$output2" : $output1 : undef +} + +sub sys { my ($s, @a) = @_; $s->_sys(4e4, @a) // "" } +sub bsys { my ($s, @a) = @_; $s->_sys(0, @a) // "" } sub fsys { my ($s, @a) = @_; $s->_sys(4e4, @a) // die "Can't run @a\n" } sub fbsys { my ($s, @a) = @_; $s->_sys(0, @a) // die "Can't run @a\n" } sub add_modules { - my $self = shift; - push @{$self->modules}, @_; + my $self = shift; + push @{ $self->modules }, @_; } sub set_modules { - my $self = shift; - @{$self->modules} = @_; + my $self = shift; + @{ $self->modules } = @_; } sub set_module_file { - my $self = shift; - my ($file) = @_; - $self->set_module_file($file); + my $self = shift; + my ($file) = @_; + $self->set_module_file($file); } sub process_module_file { - my $self = shift; - my $file = $self->module_file; - return unless defined $file && length $file; - open my $fh, "<", $file or die "Can't open $file: $!"; - my $modules = do { local $/; <$fh> }; - close $fh or die "Can't close $file: $!"; - my @modules = grep /\S/, grep !/^ *#/, split /\n/, $modules; - $self->add_modules(@modules); + my $self = shift; + my $file = $self->module_file; + return unless defined $file && length $file; + open my $fh, "<", $file or die "Can't open $file: $!"; + my $modules = do { local $/; <$fh> }; + close $fh or die "Can't close $file: $!"; + my @modules = grep /\S/, grep !/^ *#/, split /\n/, $modules; + $self->add_modules(@modules); } sub build_modules { - my $self = shift; - my @command = qw( cpan -i -T ); - push @command, "-f" if $self->force; - # my @command = qw( cpan ); - # $ENV{CPAN_OPTS} = "-i -T"; - # $ENV{CPAN_OPTS} .= " -f" if $self->force; - # $self->_set_local_timeout(300); - my %m; - for my $module (sort grep !$m{$_}++, @{$self->modules}) { - say "Building $module"; - my $output = $self->fsys(@command, $module); - say $output; - } - $self->_set_local_timeout(0); + my $self = shift; + my @command = qw( cpan -i -T ); + push @command, "-f" if $self->force; + # my @command = qw( cpan ); + # $ENV{CPAN_OPTS} = "-i -T"; + # $ENV{CPAN_OPTS} .= " -f" if $self->force; + # $self->_set_local_timeout(300); + my %m; + for my $module (sort grep !$m{$_}++, @{ $self->modules }) { + say "Building $module"; + my $output = $self->fsys(@command, $module); + say $output; + } + $self->_set_local_timeout(0); } sub add_build_dirs { - my $self = shift; - # say "add_build_dirs"; say for @{$self->build_dirs}; - # say && system "ls -al $_" for "/remote_staging", - # map "$_/build", @{$self->cpan_dir}; - my $exists = sub { - # say "exists [$_]"; - my $dir = "/remote_staging/" . (s|.*/||r =~ s/-\d+$/*/r); - my @files = glob $dir; - # say "checking [$dir] -> [@files]"; - @files - }; - push @{$self->build_dirs}, - grep { !$exists->() } - grep -d, - map glob("$_/build/*"), @{$self->cpan_dir}; - # say "add_build_dirs:"; say for @{$self->build_dirs}; + my $self = shift; + # say "add_build_dirs"; say for @{$self->build_dirs}; + # say && system "ls -al $_" for "/remote_staging", + # map "$_/build", @{$self->cpan_dir}; + my $exists = sub { + # say "exists [$_]"; + my $dir = "/remote_staging/" . (s|.*/||r =~ s/-\d+$/*/r); + my @files = glob $dir; + # say "checking [$dir] -> [@files]"; + @files + }; + push @{ $self->build_dirs }, grep { !$exists->() } grep -d, + map glob("$_/build/*"), @{ $self->cpan_dir }; + # say "add_build_dirs:"; say for @{$self->build_dirs}; } sub run { - my $self = shift; - my ($build_dir) = @_; - - my ($module) = $build_dir =~ m|.*/([^/]+?)(?:-\d+)$| or return; - my $db = "$build_dir/cover_db"; - my $line = "=" x 80; - my $output = "**** Checking coverage of $module ****\n"; - my $results_dir = $self->results_dir // die "No results dir"; - $output .= $self->fsys("mkdir", "-p", $results_dir); - $results_dir .= "/$module"; - - chdir $build_dir or die "Can't chdir $build_dir: $!\n"; - say "Checking coverage of $module"; - - if (-d $db || -d "$build_dir/structure" || -d $results_dir) { - $output .= "Already analysed\n"; - unless ($self->force) { - say "\n$line\n$output$line\n"; - return; - } - } - $output .= "Testing $module in $build_dir\n"; - # say "\n$line\n$output$line\n"; return; + my $self = shift; + my ($build_dir) = @_; - # $output .= $self->sys($^X, "-V"); - # $output .= $self->sys("pwd"); - my @cmd; - if ($self->local) { - $ENV{DEVEL_COVER_OPTIONS} = "-ignore,/usr/local/lib/perl5"; - $ENV{DEVEL_COVER_TEST_OPTS} = "-Mblib=" . $self->bin_dir; - @cmd = ($^X, $ENV{DEVEL_COVER_TEST_OPTS}, $self->bin_dir . "/cover"); - } else { - @cmd = ($^X, $self->bin_dir . "/cover"); - } - $output .= $self->fbsys( - @cmd, "--test", - "--report", $self->report, - "--outputfile", $self->output_file, - ); - $output .= $self->fsys(@cmd, "-report", "json", "-nosummary"); + my ($module) = $build_dir =~ m|.*/([^/]+?)(?:-\d+)$| or return; + my $db = "$build_dir/cover_db"; + my $line = "=" x 80; + my $output = "**** Checking coverage of $module ****\n"; + my $results_dir = $self->results_dir // die "No results dir"; + + $output .= $self->fsys("mkdir", "-p", $results_dir); + $results_dir .= "/$module"; - # TODO - option to merge DB with existing one - # TODO - portability - $output .= $self->fsys("rm", "-rf", $results_dir); - $output .= $self->fsys("mv", $db, $results_dir); - $output .= $self->fsys("rm", "-rf", $db); + chdir $build_dir or die "Can't chdir $build_dir: $!\n"; + say "Checking coverage of $module"; - say "\n$line\n$output$line\n"; + if (-d $db || -d "$build_dir/structure" || -d $results_dir) { + $output .= "Already analysed\n"; + unless ($self->force) { + say "\n$line\n$output$line\n"; + return; + } + } + + $output .= "Testing $module in $build_dir\n"; + # say "\n$line\n$output$line\n"; return; + + # $output .= $self->sys($^X, "-V"); + # $output .= $self->sys("pwd"); + my @cmd; + if ($self->local) { + $ENV{DEVEL_COVER_OPTIONS} = "-ignore,/usr/local/lib/perl5"; + $ENV{DEVEL_COVER_TEST_OPTS} = "-Mblib=" . $self->bin_dir; + @cmd = ($^X, $ENV{DEVEL_COVER_TEST_OPTS}, $self->bin_dir . "/cover"); + } else { + @cmd = ($^X, $self->bin_dir . "/cover"); + } + $output + .= $self->fbsys(@cmd, "--test", "--report", $self->report, "--outputfile", + $self->output_file); + $output .= $self->fsys(@cmd, "-report", "json", "-nosummary"); + + # TODO - option to merge DB with existing one + # TODO - portability + $output .= $self->fsys("rm", "-rf", $results_dir); + $output .= $self->fsys("mv", $db, $results_dir); + $output .= $self->fsys("rm", "-rf", $db); + + say "\n$line\n$output$line\n"; } sub run_all { - my $self = shift; + my $self = shift; - my $results_dir = $self->results_dir // die "No results dir"; - $self->fsys("mkdir", "-p", $results_dir); + my $results_dir = $self->results_dir // die "No results dir"; + $self->fsys("mkdir", "-p", $results_dir); - my @res = iterate_as_array( - { workers => $self->workers }, - sub { - my (undef, $dir) = @_; - eval { $self->run($dir) }; - warn "\n\n\n[$dir]: $@\n\n\n" if $@; - }, - $self->build_dirs - ); - # print Dumper \@res; + my @res = iterate_as_array( + { workers => $self->workers }, + sub { + my (undef, $dir) = @_; + eval { $self->run($dir) }; + warn "\n\n\n[$dir]: $@\n\n\n" if $@; + }, + $self->build_dirs + ); + # print Dumper \@res; } sub write_json { - my $self = shift; - my ($vars) = @_; - - # print Dumper $vars; - my $results = {}; - for my $module (keys %{$vars->{vals}}) { - my $m = $vars->{vals}{$module}; - my $mod = $m->{module}; - my ($name, $version) = - ($mod->{module} // $module) =~ /(.+)-(\d+\.\d+)$/; - $name = $mod->{name} if defined $mod->{name}; - $version = $mod->{version} if defined $mod->{version}; - if (defined $name && defined $version) { - $results->{$name}{$version}{coverage}{total} = { - map { $_ => $m->{$_}{pc} } - grep $m->{$_}{pc} ne 'n/a', - grep !/link|log|module/, - keys %$m - }; - } else { - print "Cannot process $module: ", Dumper $m if $self->verbose; - } - }; - # print Dumper $vars, $results; + my $self = shift; + my ($vars) = @_; + + # print Dumper $vars; + my $results = {}; + for my $module (keys %{ $vars->{vals} }) { + my $m = $vars->{vals}{$module}; + my $mod = $m->{module}; + my ($name, $version) = ($mod->{module} // $module) =~ /(.+)-(\d+\.\d+)$/; + $name = $mod->{name} if defined $mod->{name}; + $version = $mod->{version} if defined $mod->{version}; + if (defined $name && defined $version) { + $results->{$name}{$version}{coverage}{total} = { + map { $_ => $m->{$_}{pc} } grep $m->{$_}{pc} ne 'n/a', + grep !/link|log|module/, + keys %$m, + }; + } else { + print "Cannot process $module: ", Dumper $m if $self->verbose; + } + } + # print Dumper $vars, $results; - my $io = Devel::Cover::DB::IO::JSON->new(options => "pretty"); - my $file = $self->results_dir . "/cpancover.json"; - $io->write($results, $file); - say "Wrote json output to $file"; + my $io = Devel::Cover::DB::IO::JSON->new(options => "pretty"); + my $file = $self->results_dir . "/cpancover.json"; + $io->write($results, $file); + say "Wrote json output to $file"; } -sub class -{ - my ($pc) = @_; - $pc eq "n/a" ? "na" : - $pc < 75 ? "c0" : - $pc < 90 ? "c1" : - $pc < 100 ? "c2" : - "c3" +sub class { + my ($pc) = @_; + $pc eq "n/a" ? "na" + : $pc < 75 ? "c0" + : $pc < 90 ? "c1" + : $pc < 100 ? "c2" + : "c3" } sub generate_html { - my $self = shift; - - my $d = $self->results_dir; - chdir $d or die "Can't chdir $d: $!\n"; - - my $f = "$d/index.html"; - say "\n\nWriting collection output to $f ..."; - - my $vars = { - title => "Coverage report", - modules => {}, - vals => {}, - subdir => "latest/", - headers => [ grep !/path|time/, - @Devel::Cover::DB::Criteria_short, "total" ], - criteria => [ grep !/path|time/, - @Devel::Cover::DB::Criteria, "total" ], + my $self = shift; + + my $d = $self->results_dir; + chdir $d or die "Can't chdir $d: $!\n"; + + my $f = "$d/index.html"; + say "\n\nWriting collection output to $f ..."; + + my $vars = { + title => "Coverage report", + modules => {}, + vals => {}, + subdir => "latest/", + headers => + [ grep !/path|time/, @Devel::Cover::DB::Criteria_short, "total" ], + criteria => [ grep !/path|time/, @Devel::Cover::DB::Criteria, "total" ], + }; + + opendir my $dh, $d or die "Can't opendir $d: $!"; + my @modules = sort grep !/^\./, readdir $dh; + closedir $dh or die "Can't closedir $d: $!"; + + my $n = 0; + for my $module (@modules) { + my $cover = "$d/$module/cover.json"; + next unless -e $cover; + say "Adding $module" if $self->verbose; + + my $io = Devel::Cover::DB::IO::JSON->new; + my $json = $io->read($cover); + + my $mod = { + module => $module, + map { $_ => $json->{runs}[0]{$_} } qw( name version dir ), }; - - opendir my $dh, $d or die "Can't opendir $d: $!"; - my @modules = sort grep !/^\./, readdir $dh; - closedir $dh or die "Can't closedir $d: $!"; - - my $n = 0; - for my $module (@modules) { - my $cover = "$d/$module/cover.json"; - next unless -e $cover; - say "Adding $module" if $self->verbose; - - my $io = Devel::Cover::DB::IO::JSON->new; - my $json = $io->read($cover); - - my $mod = { - module => $module, - map { $_ => $json->{runs}[0]{$_} } qw( name version dir ) - }; - unless (defined $mod->{name} && defined $mod->{version}) { - my ($name, $version) = - ($mod->{module} // $module) =~ /(.+)-(\d+\.\d+)$/; - $mod->{name} //= $name; - $mod->{version} //= $version; - } - my $start = uc substr $module, 0, 1; - push @{$vars->{modules}{$start}}, $mod; - - my $m = $vars->{vals}{$module} = {}; - $m->{module} = $mod; - $m->{link} = "/$module/index.html" - if $json->{summary}{Total}{total}{total}; - - for my $criterion (@{$vars->{criteria}}) { - my $summary = $json->{summary}{Total}{$criterion}; - # print "summary:", Dumper $summary; - my $pc = $summary->{percentage}; - $pc = defined $pc ? sprintf "%.2f", $pc : "n/a"; - $m->{$criterion}{pc} = $pc; - $m->{$criterion}{class} = class($pc); - $m->{$criterion}{details} = - ($summary->{covered} || 0) . " / " . ($summary->{total} || 0); - } - - print "." if !($n++ % 1000) && !$self->verbose; + unless (defined $mod->{name} && defined $mod->{version}) { + my ($name, $version) = ($mod->{module} // $module) =~ /(.+)-(\d+\.\d+)$/; + $mod->{name} //= $name; + $mod->{version} //= $version; } + my $start = uc substr $module, 0, 1; + push @{ $vars->{modules}{$start} }, $mod; + + my $m = $vars->{vals}{$module} = {}; + $m->{module} = $mod; + $m->{link} = "/$module/index.html" if $json->{summary}{Total}{total}{total}; + + for my $criterion (@{ $vars->{criteria} }) { + my $summary = $json->{summary}{Total}{$criterion}; + # print "summary:", Dumper $summary; + my $pc = $summary->{percentage}; + $pc = defined $pc ? sprintf "%.2f", $pc : "n/a"; + $m->{$criterion}{pc} = $pc; + $m->{$criterion}{class} = class($pc); + $m->{$criterion}{details} + = ($summary->{covered} || 0) . " / " . ($summary->{total} || 0); + } + + print "." if !($n++ % 1000) && !$self->verbose; + } - $n = 0; - for my $file (@modules) { - # say "looking at [$file]"; - my ($module) = $file =~ /^ \w - \w\w - \w+ - (.*) + $n = 0; + for my $file (@modules) { + # say "looking at [$file]"; + my ($module) = $file =~ /^ \w - \w\w - \w+ - (.*) \. (?: zip | tgz | (?: tar \. (?: gz | bz2 ))) -- \d{10,11} \. \d{6} \. out \. gz $/x - or next; - # say "found at [$module]"; - $vars->{vals}{$module}{log} = $file; - print "-" if !($n++ % 1000) && !$self->verbose; - } - say ""; - - # print "vars ", Dumper $vars; - - $self->write_stylesheet; - my $template = Template->new({ - LOAD_TEMPLATES => [ - Devel::Cover::Collection::Template::Provider->new({}), - ], - }); - $template->process("summary", $vars, $f) or die $template->error; - for my $start (sort keys %{$vars->{modules}}) { - $vars->{module_start} = $start; - my $dist = "$d/dist/$start.html"; - $template->process("module_by_start", $vars, $dist) - or die $template->error; - } + or next; + # say "found at [$module]"; + $vars->{vals}{$module}{log} = $file; + print "-" if !($n++ % 1000) && !$self->verbose; + } + say ""; + + # print "vars ", Dumper $vars; + + $self->write_stylesheet; + my $template = Template->new({ + LOAD_TEMPLATES => + [ Devel::Cover::Collection::Template::Provider->new({}) ] + }); + $template->process("summary", $vars, $f) or die $template->error; + for my $start (sort keys %{ $vars->{modules} }) { + $vars->{module_start} = $start; + my $dist = "$d/dist/$start.html"; + $template->process("module_by_start", $vars, $dist) or die $template->error; + } - my $about_f = "$d/about.html"; - say "\nWriting about page to $about_f ..."; + my $about_f = "$d/about.html"; + say "\nWriting about page to $about_f ..."; - $template->process("about", { subdir => "latest/" }, $about_f) - or die $template->error; + $template->process("about", { subdir => "latest/" }, $about_f) + or die $template->error; - # print Dumper $vars; - $self->write_json($vars); + # print Dumper $vars; + $self->write_json($vars); - say "Wrote collection output to $f"; + say "Wrote collection output to $f"; } sub compress_old_versions { - my $self = shift; - my ($versions) = @_; - - my $dir = $self->results_dir; - opendir my $fh, $dir or die "Can't opendir $dir: $!"; - my @dirs = sort grep -d, map "$dir/$_", readdir $fh; - closedir $fh or die "Can't closedir $dir: $!"; - - my %modules; - for my $dir (@dirs) { - my $file = "$dir/cover.json"; - my $json = JSON::MaybeXS->new(utf8 => 1, allow_blessed => 1); - open my $fh, "<", $file or next; - # say "file: $file"; - my $data = do { local $/; eval { $json->decode(<$fh>) } } or next; - next if $@; - close $fh or next; - my ($name) = $dir =~ /.+\/(.+)/; - $name =~ s/-[^-]+$//; - my @runs = grep { ($_->{name} // "") eq $name } $data->{runs}->@*; - # say "$name " . @runs; - my $run = $runs[0] // next; - my $version = $run->{version} =~ s/_//gr // next; - my $v = eval { version->parse($version)->numify }; - if ($@ || !$v) { - $v = $version; - $v =~ s/[^0-9.]//g; - my @parts = split /\./, $v; - if (@parts > 2) { - $v = shift(@parts) . "." . join "", @parts; - } - } - $v ||= 0; - push $modules{$name}->@*, { dir => $dir, version => $v }; + my $self = shift; + my ($versions) = @_; + + my $dir = $self->results_dir; + opendir my $fh, $dir or die "Can't opendir $dir: $!"; + my @dirs = sort grep -d, map "$dir/$_", readdir $fh; + closedir $fh or die "Can't closedir $dir: $!"; + + my %modules; + for my $dir (@dirs) { + my $file = "$dir/cover.json"; + my $json = JSON::MaybeXS->new(utf8 => 1, allow_blessed => 1); + open my $fh, "<", $file or next; + # say "file: $file"; + my $data + = do { local $/; eval { $json->decode(<$fh>) } } + or next; + next if $@; + close $fh or next; + my ($name) = $dir =~ /.+\/(.+)/; + $name =~ s/-[^-]+$//; + my @runs = grep { ($_->{name} // "") eq $name } $data->{runs}->@*; + # say "$name " . @runs; + my $run = $runs[0] // next; + my $version = $run->{version} =~ s/_//gr // next; + my $v = eval { version->parse($version)->numify }; + if ($@ || !$v) { + $v = $version; + $v =~ s/[^0-9.]//g; + my @parts = split /\./, $v; + if (@parts > 2) { + $v = shift(@parts) . "." . join "", @parts; + } } - - for my $name (sort keys %modules) { - # print Dumper $modules{$name}; - my @o = sort { $b->{version} <=> $a->{version} } $modules{$name}->@*; - shift @o for 1 .. $versions; - for my $v (@o) { - my ($d, $s) = $v->{dir} =~ /(.+)\/(.+)/; - my $archive = "$v->{dir}.tar.xz"; - my @cmd1 = ($self->dc_file, "-r", $d, - "cpancover-uncompress-dir", $s); - my @cmd2 = ("bash", "-c", - "tar cf - -C $d $s | xz -z > $archive"); - my @cmd3 = ("rm", "-rf", $v->{dir}); - if ($self->dryrun) { - say for "compressing $s", "@cmd1", "@cmd2", "@cmd3"; - } else { - say "compressing $s"; - eval { - $self->fsys(@$_) for \@cmd1, \@cmd2, \@cmd3; - }; - say $@ if $@; - } - } + $v ||= 0; + push $modules{$name}->@*, { dir => $dir, version => $v }; + } + + for my $name (sort keys %modules) { + # print Dumper $modules{$name}; + my @o = sort { $b->{version} <=> $a->{version} } $modules{$name}->@*; + shift @o for 1 .. $versions; + for my $v (@o) { + + my ($d, $s) = $v->{dir} =~ /(.+)\/(.+)/; + my $archive = "$v->{dir}.tar.xz"; + my @cmd1 = ($self->dc_file, "-r", $d, "cpancover-uncompress-dir", $s); + my @cmd2 = ("bash", "-c", "tar cf - -C $d $s | xz -z > $archive"); + my @cmd3 = ("rm", "-rf", $v->{dir}); + + if ($self->dryrun) { + say for "compressing $s", "@cmd1", "@cmd2", "@cmd3"; + } else { + say "compressing $s"; + eval { $self->fsys(@$_) for \@cmd1, \@cmd2, \@cmd3; }; + say $@ if $@; + } } + } } sub local_build { - my $self = shift; + my $self = shift; - $self->process_module_file; - $self->build_modules; - $self->add_build_dirs; - $self->run_all; + $self->process_module_file; + $self->build_modules; + $self->add_build_dirs; + $self->run_all; } sub failed_dir { - my $self = shift; - my $dir = $self->results_dir . "/__failed__"; - -d $dir or mkdir $dir or die "Can't mkdir $dir: $!"; - $dir + my $self = shift; + my $dir = $self->results_dir . "/__failed__"; + -d $dir or mkdir $dir or die "Can't mkdir $dir: $!"; + $dir } sub covered_dir { - my $self = shift; - my ($dir) = @_; - $self->results_dir . "/$dir" + my $self = shift; + my ($dir) = @_; + $self->results_dir . "/$dir" } sub failed_file { - my $self = shift; - my ($dir) = @_; - $self->failed_dir . "/$dir" + my $self = shift; + my ($dir) = @_; + $self->failed_dir . "/$dir" } sub is_covered { - my $self = shift; - my ($dir) = @_; - -d $self->covered_dir($dir) + my $self = shift; + my ($dir) = @_; + -d $self->covered_dir($dir) } sub is_failed { - my $self = shift; - my ($dir) = @_; - -e $self->failed_file($dir) + my $self = shift; + my ($dir) = @_; + -e $self->failed_file($dir) } sub set_covered { - my $self = shift; - my ($dir) = @_; - unlink $self->failed_file($dir); + my $self = shift; + my ($dir) = @_; + unlink $self->failed_file($dir); } sub set_failed { - my $self = shift; - my ($dir) = @_; - my $ff = $self->failed_file($dir); - open my $fh, ">", $ff or return warn "Can't open $ff: $!"; - print $fh scalar localtime; - close $fh or warn "Can't close $ff: $!"; + my $self = shift; + my ($dir) = @_; + my $ff = $self->failed_file($dir); + open my $fh, ">", $ff or return warn "Can't open $ff: $!"; + print $fh scalar localtime; + close $fh or warn "Can't close $ff: $!"; } sub dc_file { - my $self = shift; - my $dir = ""; - $dir = "/dc/" if $self->local && -d "/dc"; - "${dir}utils/dc" + my $self = shift; + my $dir = ""; + $dir = "/dc/" if $self->local && -d "/dc"; + "${dir}utils/dc" } sub cover_modules { - my $self = shift; - - $self->process_module_file; - # say "modules: ", Dumper $self->modules; - - my @cmd = $self->dc_file; - push @cmd, "--local" if $self->local; - my @command = (@cmd, "cpancover-docker-module"); - $self->_set_local_timeout(0); - my @res = iterate_as_array( - { workers => $self->workers }, - sub { - # say "mod ", Dumper \@_; - my (undef, $module) = @_; - my $dir = $module =~ s|.*/||r - =~ s/\.(?:zip|tgz|(?:tar\.(?:gz|bz2)))$//r; - if ($self->is_covered($dir)) { - $self->set_covered($dir); - say "$module already covered" if $self->verbose; - return unless $self->force; - } elsif ($self->is_failed($dir)) { - say "$module already failed" if $self->verbose; - return unless $self->force; - } - - my $timeout = $self->local_timeout || $self->timeout || 30 * 60; - # say "Setting alarm for $timeout seconds"; - my $name = sprintf("%s-%18.6f", $module, time) - =~ tr/a-zA-Z0-9_./-/cr; - say "$dir -> $name"; - eval { - local $SIG{ALRM} = sub { die "alarm\n" }; - alarm $timeout; - say "running: @command $module $name" if $self->verbose; - system @command, $module, $name; - alarm 0; - }; - if ($@) { - die "$@" unless $@ eq "alarm\n"; # unexpected errors - say "Timed out after $timeout seconds!"; - $self->sys($self->docker, "kill", $name); - say "Killed docker container $name"; - } - - if ($self->is_covered($dir)) { - $self->set_covered($dir); - say "$dir done"; - } else { - $self->set_failed($dir); - say "$dir failed"; - } - }, - do { my %m; [sort grep !$m{$_}++, @{$self->modules}] } - ); - $self->_set_local_timeout(0); + my $self = shift; + + $self->process_module_file; + # say "modules: ", Dumper $self->modules; + + my @cmd = $self->dc_file; + push @cmd, "--local" if $self->local; + my @command = (@cmd, "cpancover-docker-module"); + $self->_set_local_timeout(0); + my @res = iterate_as_array( + { workers => $self->workers }, + sub { + # say "mod ", Dumper \@_; + my (undef, $module) = @_; + my $dir + = $module =~ s|.*/||r =~ s/\.(?:zip|tgz|(?:tar\.(?:gz|bz2)))$//r; + if ($self->is_covered($dir)) { + $self->set_covered($dir); + say "$module already covered" if $self->verbose; + return unless $self->force; + } elsif ($self->is_failed($dir)) { + say "$module already failed" if $self->verbose; + return unless $self->force; + } + + my $timeout = $self->local_timeout || $self->timeout || 30 * 60; + # say "Setting alarm for $timeout seconds"; + my $name = sprintf("%s-%18.6f", $module, time) =~ tr/a-zA-Z0-9_./-/cr; + say "$dir -> $name"; + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm $timeout; + say "running: @command $module $name" if $self->verbose; + system @command, $module, $name; + alarm 0; + }; + if ($@) { + die "$@" unless $@ eq "alarm\n"; # unexpected errors + say "Timed out after $timeout seconds!"; + $self->sys($self->docker, "kill", $name); + say "Killed docker container $name"; + } + + if ($self->is_covered($dir)) { + $self->set_covered($dir); + say "$dir done"; + } else { + $self->set_failed($dir); + say "$dir failed"; + } + }, + do { my %m; [ sort grep !$m{$_}++, @{ $self->modules } ] } + ); + $self->_set_local_timeout(0); } sub get_latest { - my $self = shift; + my $self = shift; - require CPAN::Releases::Latest; + require CPAN::Releases::Latest; - my $latest = CPAN::Releases::Latest->new(max_age => 0); # no caching - my $iterator = $latest->release_iterator; + my $latest = CPAN::Releases::Latest->new(max_age => 0); # no caching + my $iterator = $latest->release_iterator; - while (my $release = $iterator->next_release) { - say $release->path; - # Debugging code: - # printf "%s path=%s time=%d size=%d\n", - # $release->distname, - # $release->path, - # $release->timestamp, - # $release->size; - } + while (my $release = $iterator->next_release) { + say $release->path; + # Debugging code: + # printf "%s path=%s time=%d size=%d\n", + # $release->distname, + # $release->path, + # $release->timestamp, + # $release->size; + } } sub write_stylesheet { - my $self = shift; + my $self = shift; - my $css = $self->results_dir . "/collection.css"; - open my $fh, ">", $css or die "Can't open $css: $!\n"; - print $fh <results_dir . "/collection.css"; + open my $fh, ">", $css or die "Can't open $css: $!\n"; + print $fh <\n"; - $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name) +sub fetch { + my $self = shift; + my ($name) = @_; + # print "Looking for <$name>\n"; + $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name) } $Templates{colours} = <<'EOT'; @@ -740,7 +728,7 @@ $Templates{html} = <<'EOT'; $add():\n", Dumper $cc; - # $cc - coverage being filled in - # $sc - structure information - # $fc - coverage from this file - # $uc - uncoverable information - } + my $self = shift; + + return $self->{cover} if $self->{cover_valid}; + + my %digests; # mapping of digests to canonical filenames + my %files; # processed files + my $cover = $self->{cover} = {}; + my $uncoverable = {}; + my $st = $self->{_structure} + // Devel::Cover::DB::Structure->new(base => $self->{base})->read_all; + + # Sometimes the start value is undefined. It's not yet clear why, but it + # probably has something to do with the code under test forking. We'll + # just try to cope with that here. + my @runs = sort { + ($self->{runs}{$b}{start} || 0) <=> ($self->{runs}{$a}{start} || 0) + || $b cmp $a + } keys %{ $self->{runs} }; + # print STDERR "runs: ", Dumper \@runs + + my %warned; + for my $run (@runs) { + last unless $st; + + my $r = $self->{runs}{$run}; + next unless $r->{collected}; # DEVEL_COVER_SELF + @{ $self->{collected} }{ @{ $r->{collected} } } = (); + $st->add_criteria(@{ $r->{collected} }); + my $count = $r->{count}; + # print STDERR "run $run, count: ", Dumper $count; + while (my ($file, $f) = each %$count) { + my $digest = $r->{digests}{$file}; + unless ($digest) { + print STDERR "Devel::Cover: Can't find digest for $file\n" + unless $Devel::Cover::Silent + || $file =~ $Devel::Cover::DB::Ignore_filenames + || ($Devel::Cover::Self_cover && $file =~ q|/Devel/Cover[./]|); + next; + } + # print STDERR "File: $file\n"; + print STDERR "Devel::Cover: merging data for $file ", + "into $digests{$digest}\n" + if !$files{$file}++ && $digests{$digest}; + + $self->uncoverable_comments($uncoverable, $file, $digest) + unless $digests{$digest}; + + # Set up data structure to hold coverage being filled in + my $ff = $file; + if ($self->{prefer_lib}) { + $ff =~ s|^blib/||; + $ff = $file unless -e $ff; + } + my $cf = $cover->{ $digests{$digest} ||= $ff } ||= {}; + + # print STDERR "st ", Dumper($st), + # "f ", Dumper($f), + # "uc ", Dumper($uncoverable->{$digest}); + while (my ($criterion, $fc) = each %$f) { + my $get = "get_$criterion"; + my $sc = $st->$get($digest); + # print STDERR "$criterion: ", Dumper $sc, $fc; + unless ($sc) { + print STDERR "Devel::Cover: Warning: can't locate ", + "structure for $criterion in $file\n" + unless $warned{$file}{$criterion}++; + next; } - # print STDERR "Cover: ", Dumper $cover; + my $cc = $cf->{$criterion} ||= {}; + my $add = "add_$criterion"; + # print STDERR "$add():\n", Dumper $cc, $sc, $fc; + $self->$add($cc, $sc, $fc, $uncoverable->{$digest}{$criterion}); + # print STDERR "--> $add():\n", Dumper $cc; + # $cc - coverage being filled in + # $sc - structure information + # $fc - coverage from this file + # $uc - uncoverable information + } } + # print STDERR "Cover: ", Dumper $cover; + } - $self->objectify_cover; - $self->{cover_valid} = 1; - $self->{cover} + $self->objectify_cover; + $self->{cover_valid} = 1; + $self->{cover} } sub run_keys { - my $self = shift; - $self->cover unless $self->{cover_valid}; - sort { $self->{runs}{$b}{start} <=> $self->{runs}{$a}{start} } - keys %{$self->{runs}}; + my $self = shift; + $self->cover unless $self->{cover_valid}; + sort { $self->{runs}{$b}{start} <=> $self->{runs}{$a}{start} } + keys %{ $self->{runs} }; } sub runs { - my $self = shift; - $self->cover unless $self->{cover_valid}; - @{$self->{runs}}{$self->run_keys} + my $self = shift; + $self->cover unless $self->{cover_valid}; + @{ $self->{runs} }{ $self->run_keys } } sub set_structure { - my $self = shift; - my ($structure) = @_; - $self->{_structure} = $structure; + my $self = shift; + my ($structure) = @_; + $self->{_structure} = $structure; } package Devel::Cover::DB::Run; our $AUTOLOAD; -sub DESTROY {} +sub DESTROY { } sub AUTOLOAD { - my $func = $AUTOLOAD; - # print STDERR "autoloading <$func>\n"; - (my $f = $func) =~ s/.*:://; - no strict "refs"; - *$func = sub { shift->{$f} }; - goto &$func + my $func = $AUTOLOAD; + # print STDERR "autoloading <$func>\n"; + (my $f = $func) =~ s/.*:://; + no strict "refs"; + *$func = sub { shift->{$f} }; + goto &$func } 1 @@ -1024,7 +1027,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/Digests.pm b/lib/Devel/Cover/DB/Digests.pm index d8575dd3..f52a2807 100644 --- a/lib/Devel/Cover/DB/Digests.pm +++ b/lib/Devel/Cover/DB/Digests.pm @@ -1,4 +1,4 @@ -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -18,66 +18,63 @@ use Devel::Cover::DB::IO; my $File = "digests"; sub new { - my $class = shift; - my $self = { - digests => {}, - @_ - }; - - die "No db specified" unless $self->{db}; - $self->{file} = "$self->{db}/$File"; - - bless $self, $class; - $self->read; - $self + my $class = shift; + my $self = { digests => {}, @_ }; + + die "No db specified" unless $self->{db}; + $self->{file} = "$self->{db}/$File"; + + bless $self, $class; + $self->read; + $self } sub read { - my $self = shift; - my $io = Devel::Cover::DB::IO->new; - $self->{digests} = $io->read($self->{file}) if -e $self->{file}; - $self + my $self = shift; + my $io = Devel::Cover::DB::IO->new; + $self->{digests} = $io->read($self->{file}) if -e $self->{file}; + $self } sub write { - my $self = shift; - my $io = Devel::Cover::DB::IO->new; - $io->write($self->{digests}, $self->{file}); - $self + my $self = shift; + my $io = Devel::Cover::DB::IO->new; + $io->write($self->{digests}, $self->{file}); + $self } sub get { - my $self = shift; - my ($digest) = @_; - $self->{digests}{$digest} + my $self = shift; + my ($digest) = @_; + $self->{digests}{$digest} } sub set { - my $self = shift; - my ($file, $digest) = @_; - $self->{digests}{$digest} = $file; + my $self = shift; + my ($file, $digest) = @_; + $self->{digests}{$digest} = $file; } sub canonical_file { - my $self = shift; - my ($file) = @_; - - my $cfile = $file; - my $digest = Devel::Cover::DB::Structure->digest($file); - if ($digest) { - my $dfile = $self->get($digest); - if ($dfile && $dfile ne $file) { - print STDERR "Devel::Cover: Adding coverage for $file to $dfile\n" - unless $Devel::Cover::Silent; - $cfile = $dfile; - } else { - $self->set($file, $digest); - } + my $self = shift; + my ($file) = @_; + + my $cfile = $file; + my $digest = Devel::Cover::DB::Structure->digest($file); + if ($digest) { + my $dfile = $self->get($digest); + if ($dfile && $dfile ne $file) { + print STDERR "Devel::Cover: Adding coverage for $file to $dfile\n" + unless $Devel::Cover::Silent; + $cfile = $dfile; + } else { + $self->set($file, $digest); } + } - # warn "[$file] => [$cfile]\n"; + # warn "[$file] => [$cfile]\n"; - $cfile + $cfile } 1 @@ -130,7 +127,7 @@ Huh? =head1 LICENCE -Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +Copyright 2011-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/File.pm b/lib/Devel/Cover/DB/File.pm index 258c2132..2476ecbc 100644 --- a/lib/Devel/Cover/DB/File.pm +++ b/lib/Devel/Cover/DB/File.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -17,34 +17,34 @@ use Devel::Cover::Criterion; use Devel::Cover::Dumper; sub calculate_summary { - my $self = shift; - my ($db, $file, $options) = @_; - - my $s = $db->{summary}{$file} ||= {}; - - for my $criterion ($self->items) { - next unless $options->{$criterion}; - for my $location ($self->$criterion()->locations) { - for my $cover (@$location) { - $cover->calculate_summary($db, $file); - } - } + my $self = shift; + my ($db, $file, $options) = @_; + + my $s = $db->{summary}{$file} ||= {}; + + for my $criterion ($self->items) { + next unless $options->{$criterion}; + for my $location ($self->$criterion()->locations) { + for my $cover (@$location) { + $cover->calculate_summary($db, $file); + } } + } } sub calculate_percentage { - my $self = shift; - my ($db, $s) = @_; - - # print STDERR Dumper $s; - for my $criterion ($self->items) { - next unless exists $s->{$criterion}; - my $c = "Devel::Cover::\u$criterion"; - # print "$c\n"; - $c->calculate_percentage($db, $s->{$criterion}); - } - Devel::Cover::Criterion->calculate_percentage($db, $s->{total}); - # print STDERR Dumper $s; + my $self = shift; + my ($db, $s) = @_; + + # print STDERR Dumper $s; + for my $criterion ($self->items) { + next unless exists $s->{$criterion}; + my $c = "Devel::Cover::\u$criterion"; + # print "$c\n"; + $c->calculate_percentage($db, $s->{$criterion}); + } + Devel::Cover::Criterion->calculate_percentage($db, $s->{total}); + # print STDERR Dumper $s; } 1 @@ -73,7 +73,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/IO.pm b/lib/Devel/Cover/DB/IO.pm index 346f9d27..c5caf7cf 100644 --- a/lib/Devel/Cover/DB/IO.pm +++ b/lib/Devel/Cover/DB/IO.pm @@ -1,4 +1,4 @@ -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -15,24 +15,24 @@ use warnings; my $Format; BEGIN { - $Format = "Sereal" if eval "use Sereal::Decoder; use Sereal::Encoder; 1"; - $Format = "JSON" if !$Format and eval { require JSON::MaybeXS; 1 }; - $Format = "Storable" if !$Format and eval "use Storable; 1"; - die "Can't load either JSON or Storable" unless $Format; + $Format = "Sereal" if eval "use Sereal::Decoder; use Sereal::Encoder; 1"; + $Format = "JSON" if !$Format and eval { require JSON::MaybeXS; 1 }; + $Format = "Storable" if !$Format and eval "use Storable; 1"; + die "Can't load either JSON or Storable" unless $Format; } sub new { - my $class = shift; + my $class = shift; - my $format = $ENV{DEVEL_COVER_DB_FORMAT} || $Format; - ($format) = $format =~ /(.*)/; # die tainting - die "Devel::Cover: Unrecognised DB format: $format" - unless $format =~ /^(?:Storable|JSON|Sereal)$/; + my $format = $ENV{DEVEL_COVER_DB_FORMAT} || $Format; + ($format) = $format =~ /(.*)/; # die tainting + die "Devel::Cover: Unrecognised DB format: $format" + unless $format =~ /^(?:Storable|JSON|Sereal)$/; - $class .= "::$format"; - eval "use $class; 1" or die "Devel::Cover: $@"; + $class .= "::$format"; + eval "use $class; 1" or die "Devel::Cover: $@"; - $class->new(options => $ENV{DEVEL_COVER_IO_OPTIONS} || "", @_) + $class->new(options => $ENV{DEVEL_COVER_IO_OPTIONS} || "", @_) } 1 @@ -85,7 +85,7 @@ Huh? =head1 LICENCE -Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +Copyright 2011-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/IO/Base.pm b/lib/Devel/Cover/DB/IO/Base.pm index 228c8fa2..72c0ea59 100644 --- a/lib/Devel/Cover/DB/IO/Base.pm +++ b/lib/Devel/Cover/DB/IO/Base.pm @@ -1,4 +1,4 @@ -# Copyright 2017-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2017-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -15,54 +15,60 @@ use Fcntl ":flock"; # VERSION sub new { - my $class = shift; - bless { @_ }, $class + my $class = shift; + bless {@_}, $class } sub _lock { - my $self = shift; - my ($file, $type) = @_; - my $lock = "$file.lock"; - open my $fh, "+>>", $lock or die "Can't open $lock: $!\n"; - flock $fh, $type or die "Can't lock $lock: $!\n"; - $fh + my $self = shift; + my ($file, $type) = @_; + my $lock = "$file.lock"; + open my $fh, "+>>", $lock or die "Can't open $lock: $!\n"; + flock $fh, $type or die "Can't lock $lock: $!\n"; + $fh } sub _read { - my $self = shift; - my ($file, $reader) = @_; - my $lock_fh = $self->_lock($file, LOCK_SH); - $reader->() + my $self = shift; + my ($file, $reader) = @_; + my $lock_fh = $self->_lock($file, LOCK_SH); + $reader->() } sub _write { - my $self = shift; - my ($file, $writer) = @_; - my $lock_fh = $self->_lock($file, LOCK_EX); - unlink $file; - $writer->(); - $self + my $self = shift; + my ($file, $writer) = @_; + my $lock_fh = $self->_lock($file, LOCK_EX); + unlink $file; + $writer->(); + $self } sub _read_fh { - my $self = shift; - my ($file, $reader) = @_; - $self->_read($file, sub { - open my $fh, "<", $file or die "Can't open $file: $!\n"; - my $data = $reader->($fh); - close $fh or die "Can't close $file: $!\n"; - $data - }) + my $self = shift; + my ($file, $reader) = @_; + $self->_read( + $file, + sub { + open my $fh, "<", $file or die "Can't open $file: $!\n"; + my $data = $reader->($fh); + close $fh or die "Can't close $file: $!\n"; + $data + } + ) } sub _write_fh { - my $self = shift; - my ($file, $writer) = @_; - $self->_write($file, sub { - open my $fh, ">", $file or die "Can't open $file: $!\n"; - $writer->($fh); - close $fh or die "Can't close $file: $!\n"; - }) + my $self = shift; + my ($file, $writer) = @_; + $self->_write( + $file, + sub { + open my $fh, ">", $file or die "Can't open $file: $!\n"; + $writer->($fh); + close $fh or die "Can't close $file: $!\n"; + } + ) } " @@ -96,7 +102,7 @@ Huh? =head1 LICENCE -Copyright 2017-2023, Paul Johnson (paul@pjcj.net) +Copyright 2017-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/IO/JSON.pm b/lib/Devel/Cover/DB/IO/JSON.pm index afc6da4f..09bb5727 100644 --- a/lib/Devel/Cover/DB/IO/JSON.pm +++ b/lib/Devel/Cover/DB/IO/JSON.pm @@ -1,4 +1,4 @@ -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -17,34 +17,40 @@ use JSON::MaybeXS (); # VERSION sub new { - my $class = shift; - my %args = @_; - my $json = JSON::MaybeXS->new(utf8 => 1, allow_blessed => 1); - $json->ascii->pretty->canonical - if exists $args{options} && $args{options} =~ /\bpretty\b/i; - my $self = $class->SUPER::new(%args, json => $json); - bless $self, $class + my $class = shift; + my %args = @_; + my $json = JSON::MaybeXS->new(utf8 => 1, allow_blessed => 1); + $json->ascii->pretty->canonical + if exists $args{options} && $args{options} =~ /\bpretty\b/i; + my $self = $class->SUPER::new(%args, json => $json); + bless $self, $class } sub read { - my $self = shift; - my ($file) = @_; - $self->_read_fh($file, sub { - my ($fh) = @_; - local $/; - my $data = eval { $self->{json}->decode(<$fh>) }; - die "Can't read $file with ", (ref $self->{json}), ": $@" if $@; - $data - }) + my $self = shift; + my ($file) = @_; + $self->_read_fh( + $file, + sub { + my ($fh) = @_; + local $/; + my $data = eval { $self->{json}->decode(<$fh>) }; + die "Can't read $file with ", (ref $self->{json}), ": $@" if $@; + $data + } + ) } sub write { - my $self = shift; - my ($data, $file) = @_; - $self->_write_fh($file, sub { - my ($fh) = @_; - print $fh $self->{json}->encode($data); - }) + my $self = shift; + my ($data, $file) = @_; + $self->_write_fh( + $file, + sub { + my ($fh) = @_; + print $fh $self->{json}->encode($data); + } + ) } 1 @@ -98,7 +104,7 @@ Huh? =head1 LICENCE -Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +Copyright 2011-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/IO/Sereal.pm b/lib/Devel/Cover/DB/IO/Sereal.pm index b90e170e..11661422 100644 --- a/lib/Devel/Cover/DB/IO/Sereal.pm +++ b/lib/Devel/Cover/DB/IO/Sereal.pm @@ -1,4 +1,4 @@ -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -20,31 +20,37 @@ use Sereal::Encoder; my ($Decoder, $Encoder); sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - bless $self, $class + my $class = shift; + my $self = $class->SUPER::new(@_); + bless $self, $class } + sub read { - my $self = shift; - my ($file) = @_; - $self->_read_fh($file, sub { - my ($fh) = @_; - local $/; - my $data = eval { - ($Decoder ||= Sereal::Decoder->new({}))->decode(<$fh>) - }; - die "Can't read $file with Sereal: $@" if $@; - $data - }) + my $self = shift; + my ($file) = @_; + $self->_read_fh( + $file, + sub { + my ($fh) = @_; + local $/; + my $data + = eval { ($Decoder ||= Sereal::Decoder->new({}))->decode(<$fh>) }; + die "Can't read $file with Sereal: $@" if $@; + $data + } + ) } sub write { - my $self = shift; - my ($data, $file) = @_; - $self->_write_fh($file, sub { - my ($fh) = @_; - print $fh ($Encoder ||= Sereal::Encoder->new({}))->encode($data); - }) + my $self = shift; + my ($data, $file) = @_; + $self->_write_fh( + $file, + sub { + my ($fh) = @_; + print $fh ($Encoder ||= Sereal::Encoder->new({}))->encode($data); + } + ) } 1 @@ -97,7 +103,7 @@ Huh? =head1 LICENCE -Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +Copyright 2011-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/IO/Storable.pm b/lib/Devel/Cover/DB/IO/Storable.pm index 91789c18..5f5408f6 100644 --- a/lib/Devel/Cover/DB/IO/Storable.pm +++ b/lib/Devel/Cover/DB/IO/Storable.pm @@ -1,4 +1,4 @@ -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -17,21 +17,21 @@ use Storable; # VERSION sub new { - my $class = shift; - my $self = $class->SUPER::new(@_); - bless $self, $class + my $class = shift; + my $self = $class->SUPER::new(@_); + bless $self, $class } sub read { - my $self = shift; - my ($file) = @_; - $self->_read($file, sub { Storable::retrieve($file) }) + my $self = shift; + my ($file) = @_; + $self->_read($file, sub { Storable::retrieve($file) }) } sub write { - my $self = shift; - my ($data, $file) = @_; - $self->_write($file, sub { Storable::nstore($data, $file) }) + my $self = shift; + my ($data, $file) = @_; + $self->_write($file, sub { Storable::nstore($data, $file) }) } 1 @@ -84,7 +84,7 @@ Huh? =head1 LICENCE -Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +Copyright 2011-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/DB/Structure.pm b/lib/Devel/Cover/DB/Structure.pm index f030ae16..b40eb752 100644 --- a/lib/Devel/Cover/DB/Structure.pm +++ b/lib/Devel/Cover/DB/Structure.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -24,320 +24,321 @@ use constant DEBUG => 0; our $AUTOLOAD; sub new { - my $class = shift; - my $self = { @_ }; - bless $self, $class + my $class = shift; + my $self = {@_}; + bless $self, $class } -sub DESTROY {} +sub DESTROY { } sub AUTOLOAD { - my $self = $_[0]; - my $func = $AUTOLOAD; - $func =~ s/.*:://; - my ($function, $criterion) = $func =~ /^(add|get)_(.*)/; - croak "Undefined subroutine $func called" - unless $criterion && - grep $_ eq $criterion, @Devel::Cover::DB::Criteria, - qw( sub_name file line ); - no strict "refs"; - if ($function eq "get") { - my $c = $criterion eq "time" ? "statement" : $criterion; - if (grep $_ eq $c, qw( sub_name file line )) { - *$func = sub { shift->{$c} }; - } else { - *$func = sub { - my $self = shift; - my $digest = shift; - # print STDERR "file: $digest, condition: $c\n"; - for my $fval (values %{$self->{f}}) { - return $fval->{$c} if $fval->{digest} eq $digest; - } - return - } - }; + my $self = $_[0]; + my $func = $AUTOLOAD; + $func =~ s/.*:://; + my ($function, $criterion) = $func =~ /^(add|get)_(.*)/; + croak "Undefined subroutine $func called" + unless $criterion && grep $_ eq $criterion, @Devel::Cover::DB::Criteria, + qw( sub_name file line ); + no strict "refs"; + if ($function eq "get") { + my $c = $criterion eq "time" ? "statement" : $criterion; + if (grep $_ eq $c, qw( sub_name file line )) { + *$func = sub { shift->{$c} }; } else { - *$func = sub { - my $self = shift; - my $file = shift; - push @{$self->{f}{$file}{$criterion}}, @_; - }; + *$func = sub { + my $self = shift; + my $digest = shift; + # print STDERR "file: $digest, condition: $c\n"; + for my $fval (values %{ $self->{f} }) { + return $fval->{$c} if $fval->{digest} eq $digest; + } + return + } } - goto &$func + } else { + *$func = sub { + my $self = shift; + my $file = shift; + push @{ $self->{f}{$file}{$criterion} }, @_; + }; + } + goto &$func } sub debuglog { - my $self = shift; - my $dir = "$self->{base}/debuglog"; - unless (mkdir $dir) { - confess "Can't mkdir $dir: $!" unless -d $dir; - } - - local $\; - # One log file per process, as we're potentially dumping out large amounts, - # and might exceed the atomic write size of the OS - open my $fh, '>>', "$dir/$$" or confess "Can't open $dir/$$: $!"; - print $fh "----------------" . gmtime() . "----------------\n"; - print $fh ref $_ ? Dumper($_) : $_; - print $fh "\n"; - close $fh or confess "Can't close $dir/$$: $!"; + my $self = shift; + my $dir = "$self->{base}/debuglog"; + unless (mkdir $dir) { + confess "Can't mkdir $dir: $!" unless -d $dir; + } + + local $\; + # One log file per process, as we're potentially dumping out large amounts, + # and might exceed the atomic write size of the OS + open my $fh, '>>', "$dir/$$" or confess "Can't open $dir/$$: $!"; + print $fh "----------------" . gmtime() . "----------------\n"; + print $fh ref $_ ? Dumper($_) : $_; + print $fh "\n"; + close $fh or confess "Can't close $dir/$$: $!"; } sub add_criteria { - my $self = shift; - @{$self->{criteria}}{@_} = (); - $self + my $self = shift; + @{ $self->{criteria} }{@_} = (); + $self } sub criteria { - my $self = shift; - keys %{$self->{criteria}} + my $self = shift; + keys %{ $self->{criteria} } } sub set_subroutine { - my $self = shift; - my ($sub_name, $file, $line, $scount) = - @{$self}{qw( sub_name file line scount )} = @_; - - # When new code is added at runtime, via a string eval in some guise, we - # need information about where structure information for the subroutine - # is. This information is stored in $self->{f}{$file}{start} keyed on the - # filename, line number, subroutine name and the count, the count being - # for when there are multiple subroutines of the same name on the same - # line (such subroutines generally being called BEGIN). - - # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", - # Dumper $self->{f}{$file}{start}; - $self->{additional} = 0; - if ($self->reuse($file)) { - # reusing a structure - if (exists $self->{f}{$file}{start}{$line}{$sub_name}[$scount]) { - # sub already exists - normal case - # print STDERR "reuse $file:$line:$sub_name\n"; - $self->{count}{$_}{$file} = - $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} - for $self->criteria; - } else { - # sub doesn't exist, for example a conditional C - $self->{additional} = 1; - if (exists $self->{additional_count}{($self->criteria)[0]}{$file}) { - # already had such a sub in module - # print STDERR "reuse additional $file:$line:$sub_name\n"; - $self->{count}{$_}{$file} = - $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = - ($self->add_count($_))[0] - for $self->criteria; - } else { - # first such a sub in module - # print STDERR "reuse first $file:$line:$sub_name\n"; - $self->{count}{$_}{$file} = - $self->{additional_count}{$_}{$file} = - $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = - $self->{f}{$file}{start}{-1}{"__COVER__"}[$scount]{$_} - for $self->criteria; - } - } + my $self = shift; + my ($sub_name, $file, $line, $scount) + = @{$self}{qw( sub_name file line scount )} = @_; + + # When new code is added at runtime, via a string eval in some guise, we + # need information about where structure information for the subroutine + # is. This information is stored in $self->{f}{$file}{start} keyed on the + # filename, line number, subroutine name and the count, the count being + # for when there are multiple subroutines of the same name on the same + # line (such subroutines generally being called BEGIN). + + # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", + # Dumper $self->{f}{$file}{start}; + $self->{additional} = 0; + if ($self->reuse($file)) { + # reusing a structure + if (exists $self->{f}{$file}{start}{$line}{$sub_name}[$scount]) { + # sub already exists - normal case + # print STDERR "reuse $file:$line:$sub_name\n"; + $self->{count}{$_}{$file} + = $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} + for $self->criteria; } else { - # first time sub seen in new structure - # print STDERR "new $file:$line:$sub_name\n"; - $self->{count}{$_}{$file} = - $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} = - $self->get_count($file, $_) - for $self->criteria; + # sub doesn't exist, for example a conditional C + $self->{additional} = 1; + if (exists $self->{additional_count}{ ($self->criteria)[0] }{$file}) { + # already had such a sub in module + # print STDERR "reuse additional $file:$line:$sub_name\n"; + $self->{count}{$_}{$file} + = $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} + = ($self->add_count($_))[0] + for $self->criteria; + } else { + # first such a sub in module + # print STDERR "reuse first $file:$line:$sub_name\n"; + $self->{count}{$_}{$file} = $self->{additional_count}{$_}{$file} + = $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} + = $self->{f}{$file}{start}{-1}{"__COVER__"}[$scount]{$_} + for $self->criteria; + } } - # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", - # Dumper $self->{f}{$file}{start}; + } else { + # first time sub seen in new structure + # print STDERR "new $file:$line:$sub_name\n"; + $self->{count}{$_}{$file} + = $self->{f}{$file}{start}{$line}{$sub_name}[$scount]{$_} + = $self->get_count($file, $_) + for $self->criteria; + } + # print STDERR "set_subroutine start $file:$line $sub_name($scount) ", + # Dumper $self->{f}{$file}{start}; } sub store_counts { - my $self = shift; - my ($file) = @_; - $self->{count}{$_}{$file} = - $self->{f}{$file}{start}{-1}{__COVER__}[0]{$_} = - $self->get_count($file, $_) - for $self->criteria; - # print STDERR "store_counts: ", Dumper $self->{f}{$file}{start}; + my $self = shift; + my ($file) = @_; + $self->{count}{$_}{$file} = $self->{f}{$file}{start}{-1}{__COVER__}[0]{$_} + = $self->get_count($file, $_) + for $self->criteria; + # print STDERR "store_counts: ", Dumper $self->{f}{$file}{start}; } sub reuse { - my $self = shift; - my ($file) = @_; - exists $self->{f}{$file}{start}{-1}{"__COVER__"} - # TODO - exists $self->{f}{$file}{start}{-1} + my $self = shift; + my ($file) = @_; + exists $self->{f}{$file}{start}{-1}{"__COVER__"} + # TODO - exists $self->{f}{$file}{start}{-1} } sub set_file { - my $self = shift; - my ($file) = @_; - $self->{file} = $file; - my $digest = $self->digest($file); - if ($digest) { - # print STDERR "Adding $digest for $file\n"; - $self->{f}{$file}{digest} = $digest; - push @{$self->{digests}{$digest}}, $file; - } - $digest + my $self = shift; + my ($file) = @_; + $self->{file} = $file; + my $digest = $self->digest($file); + if ($digest) { + # print STDERR "Adding $digest for $file\n"; + $self->{f}{$file}{digest} = $digest; + push @{ $self->{digests}{$digest} }, $file; + } + $digest } sub digest { - my $self = shift; - my ($file) = @_; - - # print STDERR "Opening $file for MD5 digest\n"; - - my $digest; - if (open my $fh, "<", $file) { - binmode $fh; - $digest = Digest::MD5->new->addfile($fh)->hexdigest; - } else { - print STDERR "Devel::Cover: Warning: can't open $file " . - "for MD5 digest: $!\n" - unless lc $file eq "-e" or - $Devel::Cover::Silent or - $file =~ $Devel::Cover::DB::Ignore_filenames; - # require "Cwd"; print STDERR Carp::longmess("in " . Cwd::cwd()); - } - $digest + my $self = shift; + my ($file) = @_; + + # print STDERR "Opening $file for MD5 digest\n"; + + my $digest; + if (open my $fh, "<", $file) { + binmode $fh; + $digest = Digest::MD5->new->addfile($fh)->hexdigest; + } else { + print STDERR "Devel::Cover: Warning: can't open $file " + . "for MD5 digest: $!\n" + unless lc $file eq "-e" + or $Devel::Cover::Silent + or $file =~ $Devel::Cover::DB::Ignore_filenames; + # require "Cwd"; print STDERR Carp::longmess("in " . Cwd::cwd()); + } + $digest } sub get_count { - my $self = shift; - my ($file, $criterion) = @_; - $self->{count}{$criterion}{$file} + my $self = shift; + my ($file, $criterion) = @_; + $self->{count}{$criterion}{$file} } sub add_count { - my $self = shift; - # warn Carp::longmess("undefined file") unless defined $self->{file}; - return unless defined $self->{file}; # can happen during self_cover - my ($criterion) = @_; - $self->{additional_count}{$criterion}{$self->{file}}++ - if $self->{additional}; - ($self->{count}{$criterion}{$self->{file}}++, - !$self->reuse($self->{file}) || $self->{additional}) + my $self = shift; + # warn Carp::longmess("undefined file") unless defined $self->{file}; + return unless defined $self->{file}; # can happen during self_cover + my ($criterion) = @_; + $self->{additional_count}{$criterion}{ $self->{file} }++ + if $self->{additional}; + ( + $self->{count}{$criterion}{ $self->{file} }++, + !$self->reuse($self->{file}) || $self->{additional}, + ) } sub delete_file { - my $self = shift; - my ($file) = @_; - delete $self->{f}{$file}; + my $self = shift; + my ($file) = @_; + delete $self->{f}{$file}; } # TODO - concurrent runs updating structure? sub write { - my $self = shift; - my ($dir) = @_; - # print STDERR Dumper $self; - $dir .= "/structure"; - unless (mkdir $dir) { - confess "Can't mkdir $dir: $!" unless -d $dir; + my $self = shift; + my ($dir) = @_; + # print STDERR Dumper $self; + $dir .= "/structure"; + unless (mkdir $dir) { + confess "Can't mkdir $dir: $!" unless -d $dir; + } + chmod 0777, $dir if $self->{loose_perms}; + for my $file (sort keys %{ $self->{f} }) { + $self->{f}{$file}{file} = $file; + my $digest = $self->{f}{$file}{digest}; + $digest = $1 if defined $digest && $digest =~ /(.*)/; # ie tainting + unless ($digest) { + print STDERR "Can't find digest for $file" + unless $Devel::Cover::Silent + || $file =~ $Devel::Cover::DB::Ignore_filenames + || ($Devel::Cover::Self_cover && $file =~ q|/Devel/Cover[./]|); + next; } - chmod 0777, $dir if $self->{loose_perms}; - for my $file (sort keys %{$self->{f}}) { - $self->{f}{$file}{file} = $file; - my $digest = $self->{f}{$file}{digest}; - $digest = $1 if defined $digest && $digest =~ /(.*)/; # ie tainting - unless ($digest) { - print STDERR "Can't find digest for $file" - unless $Devel::Cover::Silent || - $file =~ $Devel::Cover::DB::Ignore_filenames || - ($Devel::Cover::Self_cover && - $file =~ q|/Devel/Cover[./]|); - next; - } - my $df_final = "$dir/$digest"; - my $df_temp = "$dir/.$digest.$$"; - # TODO - determine if Structure has changed to save writing it - # my $f = $df; my $n = 1; $df = $f . "." . $n++ while -e $df; - my $io = Devel::Cover::DB::IO->new; - $io->write($self->{f}{$file}, $df_temp); # unless -e $df; - unless (rename $df_temp, $df_final) { - unless ($Devel::Cover::Silent) { - if(-e $df_final) { - print STDERR "Can't rename $df_temp to $df_final " . - "(which exists): $!"; - $self->debuglog("Can't rename $df_temp to $df_final " . - "(which exists): $!") - if DEBUG; - } else { - print STDERR "Can't rename $df_temp to $df_final: $!"; - $self->debuglog("Can't rename $df_temp to $df_final: $!") - if DEBUG; - } - } - unless (unlink $df_temp) { - print STDERR "Can't remove $df_temp after failed rename: $!" - unless $Devel::Cover::Silent; - $self->debuglog("Can't remove $df_temp after failed rename: $!") - if DEBUG; - } + my $df_final = "$dir/$digest"; + my $df_temp = "$dir/.$digest.$$"; + # TODO - determine if Structure has changed to save writing it + # my $f = $df; my $n = 1; $df = $f . "." . $n++ while -e $df; + my $io = Devel::Cover::DB::IO->new; + $io->write($self->{f}{$file}, $df_temp); # unless -e $df; + unless (rename $df_temp, $df_final) { + unless ($Devel::Cover::Silent) { + if (-e $df_final) { + print STDERR "Can't rename $df_temp to $df_final " + . "(which exists): $!"; + $self->debuglog( + "Can't rename $df_temp to $df_final " . "(which exists): $!") + if DEBUG; + } else { + print STDERR "Can't rename $df_temp to $df_final: $!"; + $self->debuglog("Can't rename $df_temp to $df_final: $!") if DEBUG; } + } + unless (unlink $df_temp) { + print STDERR "Can't remove $df_temp after failed rename: $!" + unless $Devel::Cover::Silent; + $self->debuglog("Can't remove $df_temp after failed rename: $!") + if DEBUG; + } } + } } sub read { - my $self = shift; - my ($digest) = @_; - my $file = "$self->{base}/structure/$digest"; - my $io = Devel::Cover::DB::IO->new; - my $s = eval { $io->read($file) }; - if ($@ or !$s) { - $self->debuglog("read retrieve $file failed: $@") if DEBUG; - die $@; - } - if (DEBUG) { - foreach my $key (qw(file digest)) { - if (!defined $s->{$key}) { - $self->debuglog("retrieve $file had no $key entry. Got:\n", $s); - } - } + + my $self = shift; + my ($digest) = @_; + my $file = "$self->{base}/structure/$digest"; + my $io = Devel::Cover::DB::IO->new; + my $s = eval { $io->read($file) }; + + if ($@ or !$s) { + $self->debuglog("read retrieve $file failed: $@") if DEBUG; + die $@; + } + if (DEBUG) { + foreach my $key (qw(file digest)) { + if (!defined $s->{$key}) { + $self->debuglog("retrieve $file had no $key entry. Got:\n", $s); + } } - my $d = $self->digest($s->{file}); - # print STDERR "reading $digest from $file: ", Dumper $s; - if (!$d) { - # No digest implies that we can't read the file. Likely this is because - # it's stored with a relative path. In which case, it's not valid to - # assume that the file has been changed, and hence that we need to - # "update" the structure database on disk. - } elsif ($d eq $s->{digest}) { - $self->{f}{$s->{file}} = $s; + } + my $d = $self->digest($s->{file}); + # print STDERR "reading $digest from $file: ", Dumper $s; + if (!$d) { + # No digest implies that we can't read the file. Likely this is because + # it's stored with a relative path. In which case, it's not valid to + # assume that the file has been changed, and hence that we need to + # "update" the structure database on disk. + } elsif ($d eq $s->{digest}) { + $self->{f}{ $s->{file} } = $s; + } else { + print STDERR "Devel::Cover: Deleting old coverage ", + "for changed file $s->{file}\n"; + if (unlink $file) { + $self->debuglog( + "Deleting old coverage $file for changed " + . "$s->{file} $s->{digest} vs $d. Got:\n", + $s, "Have:\n", $self->{f}{$file} + ) if DEBUG; } else { - print STDERR "Devel::Cover: Deleting old coverage ", - "for changed file $s->{file}\n"; - if (unlink $file) { - $self->debuglog("Deleting old coverage $file for changed " - . "$s->{file} $s->{digest} vs $d. Got:\n", $s, - "Have:\n", $self->{f}{$file}) - if DEBUG; - } else { - print STDERR "Devel::Cover: can't delete $file: $!\n"; - $self->debuglog("Failed to delete coverage $file for changed " - . "$s->{file} ($!) $s->{digest} vs $d. Got:\n", $s, - "Have:\n", $self->{f}{$file}) - if DEBUG; - } + print STDERR "Devel::Cover: can't delete $file: $!\n"; + $self->debuglog( + "Failed to delete coverage $file for changed " + . "$s->{file} ($!) $s->{digest} vs $d. Got:\n", + $s, "Have:\n", $self->{f}{$file} + ) if DEBUG; } - $self + } + $self } sub read_all { - my ($self) = @_; - my $dir = $self->{base}; - $dir .= "/structure"; - opendir D, $dir or return; - for my $d (sort grep $_ !~ /\./, readdir D) { - $d = $1 if $d =~ /(.*)/; # Die tainting - $self->read($d); - } - closedir D or die "Can't closedir $dir: $!"; - $self + my ($self) = @_; + my $dir = $self->{base}; + $dir .= "/structure"; + opendir D, $dir or return; + for my $d (sort grep $_ !~ /\./, readdir D) { + $d = $1 if $d =~ /(.*)/; # Die tainting + $self->read($d); + } + closedir D or die "Can't closedir $dir: $!"; + $self } sub merge { - my $self = shift; - my ($from) = @_; - Devel::Cover::DB::_merge_hash($self->{f}, $from->{f}, "noadd"); + my $self = shift; + my ($from) = @_; + Devel::Cover::DB::_merge_hash($self->{f}, $from->{f}, "noadd"); } 1 @@ -367,7 +368,7 @@ Huh? =head1 LICENCE -Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +Copyright 2004-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Dumper.pm b/lib/Devel/Cover/Dumper.pm index 9874d3f7..77bfc849 100644 --- a/lib/Devel/Cover/Dumper.pm +++ b/lib/Devel/Cover/Dumper.pm @@ -8,7 +8,7 @@ # Author of this file: Olivier Mengué package # Private module - Devel::Cover::Dumper; + Devel::Cover::Dumper; use strict qw( vars subs ); # no refs use warnings; @@ -16,21 +16,21 @@ use warnings; # VERSION sub import { - my $caller = caller; - if (defined &{"${caller}::Dumper"} && \&{"${caller}::Dumper"} != \&Dumper) { - require Carp; - Carp::croak("Data::Dumper previously imported. " . - "Use Devel::Cover::Dumper instead."); - } - *{"${caller}::Dumper"} = \&Dumper; + my $caller = caller; + if (defined &{"${caller}::Dumper"} && \&{"${caller}::Dumper"} != \&Dumper) { + require Carp; + Carp::croak("Data::Dumper previously imported. " + . "Use Devel::Cover::Dumper instead."); + } + *{"${caller}::Dumper"} = \&Dumper; } sub Dumper { - require Data::Dumper; - no warnings "once"; - local $Data::Dumper::Indent = 1; - local $Data::Dumper::Sortkeys = 1; - Data::Dumper::Dumper(@_); + require Data::Dumper; + no warnings "once"; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Sortkeys = 1; + Data::Dumper::Dumper(@_); } 1 diff --git a/lib/Devel/Cover/Html_Common.pm b/lib/Devel/Cover/Html_Common.pm index b14473e0..cfecddfa 100644 --- a/lib/Devel/Cover/Html_Common.pm +++ b/lib/Devel/Cover/Html_Common.pm @@ -11,14 +11,14 @@ our @ISA = "Exporter"; our @EXPORT_OK = "launch"; sub launch { - my ($package, $opt) = @_; - - my $outfile = "$opt->{outputdir}/$opt->{option}{outputfile}"; - if (eval { require Browser::Open }) { - Browser::Open::open_browser($outfile); - } else { - print STDERR "Devel::Cover: -launch requires Browser::Open\n"; - } + my ($package, $opt) = @_; + + my $outfile = "$opt->{outputdir}/$opt->{option}{outputfile}"; + if (eval { require Browser::Open }) { + Browser::Open::open_browser($outfile); + } else { + print STDERR "Devel::Cover: -launch requires Browser::Open\n"; + } } =pod diff --git a/lib/Devel/Cover/Op.pm b/lib/Devel/Cover/Op.pm index e8c5e666..c61651e8 100644 --- a/lib/Devel/Cover/Op.pm +++ b/lib/Devel/Cover/Op.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -17,57 +17,56 @@ use Devel::Cover::Dumper; use Devel::Cover qw( -ignore blib -ignore \\wB\\w ); use B::Concise qw( set_style add_callback ); -my %style = - ("terse" => - ["(?(#label =>\n)?)(*( )*)#class (#addr) #name <#cover> (?([#targ])?) " - . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", +my %style = ( + "terse" => [ + "(?(#label =>\n)?)(*( )*)#class (#addr) #name <#cover> (?([#targ])?) " + . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", "(*( )*)goto #class (#addr)\n", - "#class pp_#name"], - "concise" => - ["#hyphseq2 #addr10 #cover12 (*( (x( ;)x))*)<#classsym> " - . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", + "#class pp_#name", + ], + "concise" => [ + "#hyphseq2 #addr10 #cover12 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n", " (*( )*) goto #seq\n", - "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], - "debug" => - ["#class (#addr)\n\tcover\t\t#cover\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" - . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" - . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" - . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" - . "(?(\top_sv\t\t#svaddr\n)?)", + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)", + ], + "debug" => [ + "#class (#addr)\n\tcover\t\t#cover\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n\top_seq\t\t" + . "#seqnum\n\top_flags\t#flagval\n\top_private\t#privval\n" + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" + . "(?(\top_sv\t\t#svaddr\n)?)", " GOTO #addr\n", - "#addr"], - ); + "#addr", + ], +); my @Options; sub import { - my $class = shift; - set_style(@{$style{concise}}); - for (@_) { - /-(.*)/ && exists $style{$1} - ? set_style(@{$style{$1}}) - : push @Options, $_; + my $class = shift; + set_style(@{ $style{concise} }); + for (@_) { + /-(.*)/ && exists $style{$1} ? set_style(@{ $style{$1} }) : push @Options, + $_; + } + + my $final = 1; + add_callback(sub { + my ($h, $op, $format, $level) = @_; + my $key = Devel::Cover::get_key($op); + # print Dumper Devel::Cover::coverage unless $d++; + if ($h->{seq}) { + my ($s, $b, $c) + = map Devel::Cover::coverage($final ? $final-- : 0)->{$_}{$key}, + qw(statement branch condition); + local $" = ","; + no warnings "uninitialized"; + $h->{cover} = $s ? "s[$s]" : $b ? "b[@$b]" : $c ? "c[@$c]" : ""; + } else { + $h->{cover} = ""; } - - my $final = 1; - add_callback(sub { - my ($h, $op, $format, $level) = @_; - my $key = Devel::Cover::get_key($op); - # print Dumper Devel::Cover::coverage unless $d++; - if ($h->{seq}) { - my ($s, $b, $c) = - map Devel::Cover::coverage($final ? $final-- : 0)->{$_}{$key}, - qw(statement branch condition); - local $" = ","; - no warnings "uninitialized"; - $h->{cover} = $s ? "s[$s]" : - $b ? "b[@$b]" : - $c ? "c[@$c]" : - ""; - } else { - $h->{cover} = ""; - } - }); + }); } END { B::Concise::compile(@Options)->() } @@ -102,7 +101,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Pod.pm b/lib/Devel/Cover/Pod.pm index 59771ef1..6a11896d 100644 --- a/lib/Devel/Cover/Pod.pm +++ b/lib/Devel/Cover/Pod.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -14,27 +14,26 @@ use warnings; use base "Devel::Cover::Criterion"; -BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available. +BEGIN { eval "use Pod::Coverage 0.06" } # We'll use this if it is available. -sub uncoverable { $_[0][2] } -sub covered { $_[0][0] ? 1 : 0 } -sub total { 1 } -sub percentage { $_[0][0] ? 100 : 0 } -sub error { $_[0]->simple_error } -sub criterion { "pod" } +sub uncoverable { $_[0][2] } +sub covered { $_[0][0] ? 1 : 0 } +sub total { 1 } +sub percentage { $_[0][0] ? 100 : 0 } +sub error { $_[0]->simple_error } +sub criterion { "pod" } sub calculate_summary { - my $self = shift; - my ($db, $file) = @_; + my $self = shift; + my ($db, $file) = @_; - return unless $INC{"Pod/Coverage.pm"}; + return unless $INC{"Pod/Coverage.pm"}; - my $s = $db->{summary}; + my $s = $db->{summary}; - $self->aggregate($s, $file, 'total', $self->total); - $self->aggregate($s, $file, 'covered', 1) - if $self->covered; - $self->aggregate($s, $file, 'error', $self->error); + $self->aggregate($s, $file, 'total', $self->total); + $self->aggregate($s, $file, 'covered', 1) if $self->covered; + $self->aggregate($s, $file, 'error', $self->error); } 1 @@ -65,7 +64,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Report/Compilation.pm b/lib/Devel/Cover/Report/Compilation.pm index adc0a551..e97c11ea 100644 --- a/lib/Devel/Cover/Report/Compilation.pm +++ b/lib/Devel/Cover/Report/Compilation.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -25,100 +25,100 @@ use Devel::Cover::DB; # TODO - uncoverable code? sub print_statement { - my ($db, $file, $options) = @_; + my ($db, $file, $options) = @_; - my $statements = $db->cover->file($file)->statement or return; + my $statements = $db->cover->file($file)->statement or return; - for my $location ($statements->items) { - my $l = $statements->location($location); - for my $statement (@$l) { - next if $statement->covered; - print "Uncovered statement at $file line $location:\n"; - } + for my $location ($statements->items) { + my $l = $statements->location($location); + for my $statement (@$l) { + next if $statement->covered; + print "Uncovered statement at $file line $location:\n"; } + } } sub print_branches { - my ($db, $file, $options) = @_; - - my $branches = $db->cover->file($file)->branch or return; - - for my $location (sort { $a <=> $b } $branches->items) { - for my $b (@{$branches->location($location)}) { - next unless $b->error; - - # One or both paths from this branch weren't reached. - # $b->covered(0) and (1) say whether the first and second - # paths were reached. If the branch condition text begins - # with "unless" then the meanings of 0 and 1 are swapped. - # The output is easier to understand if we strip off - # "unless" and say whether the remaining condition was - # true or false. - - my $text = $b->text; - my ($t, $f) = map $b->covered($_), - $text =~ s/^(if|unless) // && $1 eq "unless" ? (1, 0) : (0, 1); - # TODO - uncoverable code? - print "Branch never ", - $t ? ($f ? "???" : "false") : ($f ? "true" : "reached"), - " at $file line $location: $text\n"; - } + my ($db, $file, $options) = @_; + + my $branches = $db->cover->file($file)->branch or return; + + for my $location (sort { $a <=> $b } $branches->items) { + for my $b (@{ $branches->location($location) }) { + next unless $b->error; + + # One or both paths from this branch weren't reached. + # $b->covered(0) and (1) say whether the first and second + # paths were reached. If the branch condition text begins + # with "unless" then the meanings of 0 and 1 are swapped. + # The output is easier to understand if we strip off + # "unless" and say whether the remaining condition was + # true or false. + + my $text = $b->text; + my ($t, $f) = map $b->covered($_), + $text =~ s/^(if|unless) // && $1 eq "unless" ? (1, 0) : (0, 1); + # TODO - uncoverable code? + print "Branch never ", + $t ? ($f ? "???" : "false") : ($f ? "true" : "reached"), + " at $file line $location: $text\n"; } + } } sub print_conditions { - my ($db, $file, $options) = @_; + my ($db, $file, $options) = @_; - my $conditions = $db->cover->file($file)->condition or return; + my $conditions = $db->cover->file($file)->condition or return; - my $template = sub { "%-5s %3s %6s " . ( "%6s " x shift ) . " %s\n" }; - - my %r; - for my $location (sort { $a <=> $b } $conditions->items) { - my %seen; - for my $c (@{$conditions->location($location)}) { - push @{$r{$c->type}}, [ $c, $seen{$c->type}++ ? "" : $location ]; - } - } + my $template = sub { "%-5s %3s %6s " . ("%6s " x shift) . " %s\n" }; + my %r; + for my $location (sort { $a <=> $b } $conditions->items) { my %seen; - for my $type (sort keys %r) { - my $tpl; - for (@{$r{$type}}) { - my ($c, $location) = @$_; - next unless $c->error; - my @headers = @{$c->headers}; - print "Uncovered condition (", join(", ", - map (!$c->covered($_) ? $headers[$_] : (), 0..$c->total-1)), - ") at $file line $location: ", $c->text, "\n"; - } + for my $c (@{ $conditions->location($location) }) { + push @{ $r{ $c->type } }, [ $c, $seen{ $c->type }++ ? "" : $location ]; + } + } + + my %seen; + for my $type (sort keys %r) { + my $tpl; + for (@{ $r{$type} }) { + my ($c, $location) = @$_; + next unless $c->error; + my @headers = @{ $c->headers }; + print "Uncovered condition (", + join(", ", + map (!$c->covered($_) ? $headers[$_] : (), 0 .. $c->total - 1)), + ") at $file line $location: ", $c->text, "\n"; } + } } sub print_subroutines { - my ($db, $file, $options) = @_; + my ($db, $file, $options) = @_; - my $subroutines = $db->cover->file($file)->subroutine or return; + my $subroutines = $db->cover->file($file)->subroutine or return; - for my $location ($subroutines->items) { - my $l = $subroutines->location($location); - for my $sub (@$l) { - next if $sub->covered; - print "Uncovered subroutine ", $sub->name, - " at $file line $location\n"; - } + for my $location ($subroutines->items) { + my $l = $subroutines->location($location); + for my $sub (@$l) { + next if $sub->covered; + print "Uncovered subroutine ", $sub->name, " at $file line $location\n"; } + } } sub report { - my ($pkg, $db, $options) = @_; - - for my $file (@{$options->{file}}) { - print_statement ($db, $file, $options) if $options->{show}{statement}; - print_branches ($db, $file, $options) if $options->{show}{branch}; - print_conditions ($db, $file, $options) if $options->{show}{condition}; - print_subroutines($db, $file, $options) if $options->{show}{subroutine}; - } + my ($pkg, $db, $options) = @_; + + for my $file (@{ $options->{file} }) { + print_statement($db, $file, $options) if $options->{show}{statement}; + print_branches($db, $file, $options) if $options->{show}{branch}; + print_conditions($db, $file, $options) if $options->{show}{condition}; + print_subroutines($db, $file, $options) if $options->{show}{subroutine}; + } } 1 @@ -152,7 +152,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Report/Html.pm b/lib/Devel/Cover/Report/Html.pm index d4dcff31..10397757 100644 --- a/lib/Devel/Cover/Report/Html.pm +++ b/lib/Devel/Cover/Report/Html.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -43,7 +43,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Report/Html_basic.pm b/lib/Devel/Cover/Report/Html_basic.pm index bf25628d..cebf9842 100644 --- a/lib/Devel/Cover/Report/Html_basic.pm +++ b/lib/Devel/Cover/Report/Html_basic.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -11,8 +11,9 @@ use strict; use warnings; our $VERSION; + BEGIN { -# VERSION + # VERSION } use Devel::Cover::DB; @@ -29,433 +30,423 @@ use Template 2.00; my ($Have_highlighter, $Have_PPI, $Have_perltidy); BEGIN { - eval "use PPI; use PPI::HTML;"; - $Have_PPI = !$@; - eval "use Perl::Tidy"; - $Have_perltidy = !$@; - $Have_highlighter = $Have_PPI || $Have_perltidy; + eval "use PPI; use PPI::HTML;"; + $Have_PPI = !$@; + eval "use Perl::Tidy"; + $Have_perltidy = !$@; + $Have_highlighter = $Have_PPI || $Have_perltidy; } my $Template; my %R; sub oclass { - my ($o, $criterion) = @_; - $o ? class($o->percentage, $o->error, $criterion) : "" + my ($o, $criterion) = @_; + $o ? class($o->percentage, $o->error, $criterion) : "" } my $threshold = { c0 => 75, c1 => 90, c2 => 100 }; sub class { - my ($pc, $err, $criterion) = @_; - return "" if $criterion eq "time"; - no warnings "uninitialized"; - !$err ? "c3" + my ($pc, $err, $criterion) = @_; + return "" if $criterion eq "time"; + no warnings "uninitialized"; + !$err ? "c3" : $pc < $threshold->{c0} ? "c0" : $pc < $threshold->{c1} ? "c1" : $pc < $threshold->{c2} ? "c2" - : "c3" + : "c3" } sub get_summary { - my ($file, $criterion) = @_; + my ($file, $criterion) = @_; - my %vals; - @vals{"pc", "class"} = ("n/a", ""); + my %vals; + @vals{ "pc", "class" } = ("n/a", ""); - my $part = $R{db}->summary($file); - return \%vals unless exists $part->{$criterion}; - my $c = $part->{$criterion}; - $vals{class} = class($c->{percentage}, $c->{error}, $criterion); + my $part = $R{db}->summary($file); + return \%vals unless exists $part->{$criterion}; + my $c = $part->{$criterion}; + $vals{class} = class($c->{percentage}, $c->{error}, $criterion); - return \%vals unless defined $c->{percentage}; - $vals{pc} = do { my $x = sprintf "%5.2f", $c->{percentage}; chop $x; $x }; - $vals{covered} = $c->{covered} || 0; - $vals{total} = $c->{total}; - $vals{details} = "$vals{covered} / $vals{total}"; + return \%vals unless defined $c->{percentage}; + $vals{pc} = do { my $x = sprintf "%5.2f", $c->{percentage}; chop $x; $x }; + $vals{covered} = $c->{covered} || 0; + $vals{total} = $c->{total}; + $vals{details} = "$vals{covered} / $vals{total}"; - my $cr = $criterion eq "pod" ? "subroutine" : $criterion; - return \%vals if $cr !~ /^branch|condition|subroutine$/ || - !exists $R{filenames}{$file}; - $vals{link} = "$R{filenames}{$file}--$cr.html"; + my $cr = $criterion eq "pod" ? "subroutine" : $criterion; + return \%vals + if $cr !~ /^branch|condition|subroutine$/ || !exists $R{filenames}{$file}; + $vals{link} = "$R{filenames}{$file}--$cr.html"; - \%vals -}; + \%vals +} sub print_summary { - my $vars = { - R => \%R, - files => [ "Total", grep $R{db}->summary($_), @{$R{options}{file}} ], - }; + my $vars = { + R => \%R, + files => [ "Total", grep $R{db}->summary($_), @{ $R{options}{file} } ], + }; - my $html = "$R{options}{outputdir}/$R{options}{option}{outputfile}"; - $Template->process("summary", $vars, $html) or die $Template->error(); + my $html = "$R{options}{outputdir}/$R{options}{option}{outputfile}"; + $Template->process("summary", $vars, $html) or die $Template->error(); - $html + $html } sub _highlight_ppi { - my @all_lines = @_; - my $code = join "", @all_lines; - my $document = PPI::Document->new(\$code); - my $highlight = PPI::HTML->new(line_numbers => 1); - my $pretty = $highlight->html($document); - - my $split = ''; - - no warnings "uninitialized"; - - # turn significant whitespace into   - @all_lines = map { - $_ =~ s{( +)}{"" . (" " x length($1))}e; - "$split$_"; - } split /$split/, $pretty; - - # remove the line number - @all_lines = map { - s{.*?}{}; $_; - } @all_lines; - @all_lines = map { - s{}{}; $_; - } @all_lines; - - # remove the BR - @all_lines = map { - s{
$}{}; $_; - } @all_lines; - @all_lines = map { - s{
\n}{}; $_; - } @all_lines; - - shift @all_lines if $all_lines[0] eq ""; - - @all_lines + + my @all_lines = @_; + my $code = join "", @all_lines; + my $document = PPI::Document->new(\$code); + my $highlight = PPI::HTML->new(line_numbers => 1); + my $pretty = $highlight->html($document); + + my $split = ''; + + no warnings "uninitialized"; + + # turn significant whitespace into   + @all_lines = map { + $_ =~ s{( +)}{"" . (" " x length($1))}e; + "$split$_"; + } split /$split/, $pretty; + + # remove the line number + @all_lines = map { + s{.*?}{}; + $_; + } @all_lines; + @all_lines = map { + s{}{}; + $_; + } @all_lines; + + # remove the BR + @all_lines = map { + s{
$}{}; + $_; + } @all_lines; + @all_lines = map { + s{
\n}{}; + $_; + } @all_lines; + + shift @all_lines if $all_lines[0] eq ""; + + @all_lines } sub _highlight_perltidy { - my @all_lines = @_; - my @coloured; - - my ($stderr, $errorfile); - Perl::Tidy::perltidy( - source => \@all_lines, - destination => \@coloured, - argv => "-html -pre -nopod2html", - stderr => \$stderr, - errorfile => \$errorfile, - ); - - # remove the PRE - shift @coloured; - pop @coloured; - @coloured = grep { !/ \@all_lines, + destination => \@coloured, + argv => "-html -pre -nopod2html", + stderr => \$stderr, + errorfile => \$errorfile + ); + + # remove the PRE + shift @coloured; + pop @coloured; + @coloured = grep { !/cover->file($R{file}); - - open F, $R{file} or warn("Unable to open $R{file}: $!\n"), return; - my @all_lines = ; - - if (!($R{options}{option}{noppihtml} && $R{options}{option}{noperltidy})) { - @all_lines = _highlight(@all_lines) if $Have_highlighter; + my @lines; + my $f = $R{db}->cover->file($R{file}); + + open F, $R{file} or warn("Unable to open $R{file}: $!\n"), return; + my @all_lines = ; + + if (!($R{options}{option}{noppihtml} && $R{options}{option}{noperltidy})) { + @all_lines = _highlight(@all_lines) if $Have_highlighter; + } + + my $linen = 1; + LINE: while (defined(my $l = shift @all_lines)) { + my $n = $linen++; + chomp $l; + + my %criteria; + for my $c (@{ $R{showing} }) { + my $criterion = $f->$c(); + if ($criterion) { + my $l = $criterion->location($n); + $criteria{$c} = $l ? [@$l] : undef; + } } - my $linen = 1; - LINE: while (defined(my $l = shift @all_lines)) { - my $n = $linen++; - chomp $l; - - my %criteria; - for my $c (@{$R{showing}}) { - my $criterion = $f->$c(); - if ($criterion) { - my $l = $criterion->location($n); - $criteria{$c} = $l ? [@$l] : undef; - } - } - - my $count = 0; - my $more = 1; - while ($more) { - my %line; - - $count++; - $line{number} = length $n ? $n : " "; - $line{text} = length $l ? $l : " "; - - my $error = 0; - $more = 0; - for my $ann (@{$R{options}{annotations}}) { - for my $a (0 .. $ann->count - 1) { - my $text = $ann->text ($R{file}, $n, $a); - $text = " " unless $text && length $text; - push @{$line{criteria}}, { - text => $text, - class => $ann->class($R{file}, $n, $a), - }; - $error ||= $ann->error($R{file}, $n, $a); - } - } - for my $c (@{$R{showing}}) { - my $o = shift @{$criteria{$c}}; - $more ||= @{$criteria{$c}}; - my $link = $c !~ /statement|time/; - my $pc = $link && $c !~ /subroutine|pod/; - my $text = $o ? $pc ? $o->percentage : $o->covered : " "; - my %criterion = ( text => $text, class => oclass($o, $c) ); - my $cr = $c eq "pod" ? "subroutine" : $c; - $criterion{link} = "$R{filenames}{$R{file}}--$cr.html#$n-$count" - if $o && $link; - push @{$line{criteria}}, \%criterion; - $error ||= $o->error if $o; - } - - push @lines, \%line; - - last LINE if $l =~ /^__(END|DATA)__/; - $n = $l = ""; + my $count = 0; + my $more = 1; + while ($more) { + my %line; + + $count++; + $line{number} = length $n ? $n : " "; + $line{text} = length $l ? $l : " "; + + my $error = 0; + $more = 0; + for my $ann (@{ $R{options}{annotations} }) { + for my $a (0 .. $ann->count - 1) { + my $text = $ann->text($R{file}, $n, $a); + $text = " " unless $text && length $text; + push @{ $line{criteria} }, + { text => $text, class => $ann->class($R{file}, $n, $a) }; + $error ||= $ann->error($R{file}, $n, $a); } + } + for my $c (@{ $R{showing} }) { + my $o = shift @{ $criteria{$c} }; + $more ||= @{ $criteria{$c} }; + + my $link = $c !~ /statement|time/; + my $pc = $link && $c !~ /subroutine|pod/; + my $text = $o ? $pc ? $o->percentage : $o->covered : " "; + my %criterion = (text => $text, class => oclass($o, $c)); + my $cr = $c eq "pod" ? "subroutine" : $c; + + $criterion{link} = "$R{filenames}{$R{file}}--$cr.html#$n-$count" + if $o && $link; + push @{ $line{criteria} }, \%criterion; + $error ||= $o->error if $o; + } + + push @lines, \%line; + + last LINE if $l =~ /^__(END|DATA)__/; + $n = $l = ""; } - close F or die "Unable to close $R{file}: $!"; - - # Add forward references to uncovered lines ... - # first line has a ref to the first uncovered line unless - # the first line already is uncovered in which case it links - # to the *next* uncovered line - { - my @unc = grep { $_->{criteria}[0]{class} eq "c0" && - $_->{criteria}[0]{text} eq "0" } @lines; - while (@unc) { - my $u = pop @unc; - my $link = "#" . $u->{number}; - (@unc ? $unc[-1] : $lines[0])->{criteria}[0]{link} ||= $link; - } + } + close F or die "Unable to close $R{file}: $!"; + + # Add forward references to uncovered lines ... + # first line has a ref to the first uncovered line unless + # the first line already is uncovered in which case it links + # to the *next* uncovered line + { + my @unc = grep { + $_->{criteria}[0]{class} eq "c0" && $_->{criteria}[0]{text} eq "0" + } @lines; + while (@unc) { + my $u = pop @unc; + my $link = "#" . $u->{number}; + (@unc ? $unc[-1] : $lines[0])->{criteria}[0]{link} ||= $link; } + } - my $vars = { - R => \%R, - lines => \@lines, - }; + my $vars = { R => \%R, lines => \@lines }; - $Template->process("file", $vars, $R{file_html}) or die $Template->error(); + $Template->process("file", $vars, $R{file_html}) or die $Template->error(); } sub print_branches { - my $branches = $R{db}->cover->file($R{file})->branch; - return unless $branches; - - my @branches; - for my $location (sort { $a <=> $b } $branches->items) { - my $count = 0; - for my $b (@{$branches->location($location)}) { - $count++; - my $text = $b->text; - ($text) = _highlight($text) if $Have_highlighter; - - push @branches, - { - number => $count == 1 ? $location : "", - parts => [ - map { text => $b->value($_), - class => class($b->value($_), $b->error($_), - "branch") }, - 0 .. $b->total - 1 - ], - text => $text, - }; - } + my $branches = $R{db}->cover->file($R{file})->branch; + return unless $branches; + + my @branches; + for my $location (sort { $a <=> $b } $branches->items) { + my $count = 0; + for my $b (@{ $branches->location($location) }) { + $count++; + my $text = $b->text; + ($text) = _highlight($text) if $Have_highlighter; + + push @branches, { + number => $count == 1 ? $location : "", + parts => [ + map { + text => $b->value($_), + class => class($b->value($_), $b->error($_), "branch") + }, + 0 .. $b->total - 1, + ], + text => $text, + }; } + } - my $vars = { - R => \%R, - branches => \@branches, - }; + my $vars = { R => \%R, branches => \@branches }; - my $html = "$R{options}{outputdir}/$R{filenames}{$R{file}}--branch.html"; - $Template->process("branches", $vars, $html) or die $Template->error(); + my $html = "$R{options}{outputdir}/$R{filenames}{$R{file}}--branch.html"; + $Template->process("branches", $vars, $html) or die $Template->error(); } sub print_conditions { - my $conditions = $R{db}->cover->file($R{file})->condition; - return unless $conditions; - - my %r; - for my $location (sort { $a <=> $b } $conditions->items) { - my %count; - for my $c (@{$conditions->location($location)}) { - $count{$c->type}++; - # print "-- [$count{$c->type}][@{[$c->text]}]}]\n"; - my $text = $c->text; - ($text) = _highlight($text) if $Have_highlighter; - - push @{$r{$c->type}}, - { - number => $count{$c->type} == 1 ? $location : "", - condition => $c, - parts => [ - map { text => $c->value($_), - class => class($c->value($_), $c->error($_), - "condition") }, - 0 .. $c->total - 1 - ], - text => $text, - }; - } + my $conditions = $R{db}->cover->file($R{file})->condition; + return unless $conditions; + + my %r; + for my $location (sort { $a <=> $b } $conditions->items) { + my %count; + for my $c (@{ $conditions->location($location) }) { + $count{ $c->type }++; + # print "-- [$count{$c->type}][@{[$c->text]}]}]\n"; + my $text = $c->text; + ($text) = _highlight($text) if $Have_highlighter; + + push @{ $r{ $c->type } }, { + number => $count{ $c->type } == 1 ? $location : "", + condition => $c, + parts => [ + map { + text => $c->value($_), + class => class($c->value($_), $c->error($_), "condition") + }, + 0 .. $c->total - 1, + ], + text => $text, + }; } + } - my @types = map - { - name => do { my $n = $_; $n =~ s/_/ /g; $n }, - headers => [ map { encode_entities($_) } - @{$r{$_}[0]{condition}->headers || []} ], - conditions => $r{$_}, - }, sort keys %r; + my @types = map { + name => do { my $n = $_; $n =~ s/_/ /g; $n }, + headers => + [ map { encode_entities($_) } @{ $r{$_}[0]{condition}->headers || [] } ], + conditions => $r{$_}, + }, sort keys %r; - my $vars = { - R => \%R, - types => \@types, - }; + my $vars = { R => \%R, types => \@types }; - # use Devel::Cover::Dumper; print Dumper \@types; + # use Devel::Cover::Dumper; print Dumper \@types; - my $html = "$R{options}{outputdir}/$R{filenames}{$R{file}}--condition.html"; - $Template->process("conditions", $vars, $html) or die $Template->error(); + my $html = "$R{options}{outputdir}/$R{filenames}{$R{file}}--condition.html"; + $Template->process("conditions", $vars, $html) or die $Template->error(); } sub print_subroutines { - my $subroutines = $R{db}->cover->file($R{file})->subroutine; - return unless $subroutines; - my $s = $R{options}{show}{subroutine}; - - my $pods; - $pods = $R{db}->cover->file($R{file})->pod if $R{options}{show}{pod}; - - my $subs; - for my $line (sort { $a <=> $b } $subroutines->items) { - my @p; - if ($pods) { - my $l = $pods->location($line); - @p = @$l if $l; - } - for my $o (@{$subroutines->location($line)}) { - my $p = shift @p; - push @$subs, { - line => $line, - name => $o->name, - count => $s ? $o->covered : "", - class => $s ? oclass($o, "subroutine") : "", - pod => $p ? $p->covered ? "Yes" : "No" : "n/a", - pclass => $p ? oclass($p, "pod") : "", - }; - } + my $subroutines = $R{db}->cover->file($R{file})->subroutine; + return unless $subroutines; + my $s = $R{options}{show}{subroutine}; + + my $pods; + $pods = $R{db}->cover->file($R{file})->pod if $R{options}{show}{pod}; + + my $subs; + for my $line (sort { $a <=> $b } $subroutines->items) { + my @p; + if ($pods) { + my $l = $pods->location($line); + @p = @$l if $l; } + for my $o (@{ $subroutines->location($line) }) { + my $p = shift @p; + push @$subs, { + line => $line, + name => $o->name, + count => $s ? $o->covered : "", + class => $s ? oclass($o, "subroutine") : "", + pod => $p ? $p->covered ? "Yes" : "No" : "n/a", + pclass => $p ? oclass($p, "pod") : "", + }; + } + } - my $vars = { - R => \%R, - subs => $subs, - }; + my $vars = { R => \%R, subs => $subs }; - my $html = - "$R{options}{outputdir}/$R{filenames}{$R{file}}--subroutine.html"; - $Template->process("subroutines", $vars, $html) or die $Template->error(); + my $html = "$R{options}{outputdir}/$R{filenames}{$R{file}}--subroutine.html"; + $Template->process("subroutines", $vars, $html) or die $Template->error(); } sub get_options { - my ($self, $opt) = @_; - $opt->{option}{outputfile} = "coverage.html"; - $opt->{option}{restrict} = 1; - $threshold->{$_} = $opt->{"report_$_"} for - grep { defined $opt->{"report_$_"} } qw( c0 c1 c2 ); - die "Invalid command line options" unless - GetOptions($opt->{option}, - qw( - noppihtml - noperltidy - outputfile=s - restrict! - )); + my ($self, $opt) = @_; + $opt->{option}{outputfile} = "coverage.html"; + $opt->{option}{restrict} = 1; + $threshold->{$_} = $opt->{"report_$_"} + for grep { defined $opt->{"report_$_"} } qw( c0 c1 c2 ); + die "Invalid command line options" unless GetOptions( + $opt->{option}, qw( + noppihtml + noperltidy + outputfile=s + restrict! + ) + ); } sub report { - my ($pkg, $db, $options) = @_; - - $Template = Template->new({ - LOAD_TEMPLATES => [ - Devel::Cover::Report::Html_basic::Template::Provider->new({}), - ], - }); - - my $le = sub { ($_[0] > 0 ? "<" : "=") . " $_[0]" }; - my $ge = sub { ($_[0] < 100 ? ">" : "") . "= $_[0]" }; - - my $fname = (sort keys %{$db->{runs}})[0] or return; - my $run = $db->{runs}{$fname}; - - %R = ( - module => { name => $run->name, version => $run->version }, - db => $db, - date => do { - my ($sec, $min, $hour, $mday, $mon, $year) = localtime; - sprintf "%04d-%02d-%02d %02d:%02d:%02d", - $year + 1900, $mon + 1, $mday, $hour, $min, $sec - }, - perl_v => $] < 5.010 ? $] : $^V, - os => $^O, - options => $options, - version => $VERSION, - showing => [ grep $options->{show}{$_}, $db->criteria ], - headers => [ - map { ($db->criteria_short)[$_] } - grep { $options->{show}{($db->criteria)[$_]} } - (0 .. $db->criteria - 1) - ], - annotations => [ - map { my $a = $_; map $a->header($_), 0 .. $a->count - 1 } - @{$options->{annotations}} - ], - filenames => { - map { $_ => do { (my $f = $_) =~ s/\W/-/g; $f } } - @{$options->{file}} - }, - exists => { map { $_ => -e } @{$options->{file}} }, - get_summary => \&get_summary, - c0 => $le->($options->{report_c0}), - c1 => $le->($options->{report_c1}), - c2 => $le->($options->{report_c2}), - c3 => $ge->($options->{report_c2}), - ); - - write_file $R{options}{outputdir}, "all"; - - for (@{$options->{file}}) { - $R{file} = $_; - $R{file_link} = "$R{filenames}{$_}.html"; - $R{file_html} = "$options->{outputdir}/$R{file_link}"; - my $show = $options->{show}; - print_file; - print_branches if $show->{branch}; - print_conditions if $show->{condition}; - print_subroutines if $show->{subroutine} || $show->{pod}; - } - - my $html = print_summary; - print "HTML output written to $html\n" unless $options->{silent}; + my ($pkg, $db, $options) = @_; + + $Template = Template->new({ + LOAD_TEMPLATES => + [ Devel::Cover::Report::Html_basic::Template::Provider->new({}) ] + }); + + my $le = sub { ($_[0] > 0 ? "<" : "=") . " $_[0]" }; + my $ge = sub { ($_[0] < 100 ? ">" : "") . "= $_[0]" }; + + my $fname = (sort keys %{ $db->{runs} })[0] or return; + my $run = $db->{runs}{$fname}; + + %R = ( + module => { name => $run->name, version => $run->version }, + db => $db, + date => do { + my ($sec, $min, $hour, $mday, $mon, $year) = localtime; + sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, + $hour, $min, $sec + }, + perl_v => $] < 5.010 ? $] : $^V, + os => $^O, + options => $options, + version => $VERSION, + showing => [ grep $options->{show}{$_}, $db->criteria ], + headers => [ + map { ($db->criteria_short)[$_] } + grep { $options->{show}{ ($db->criteria)[$_] } } + (0 .. $db->criteria - 1) + ], + annotations => [ + map { my $a = $_; map $a->header($_), 0 .. $a->count - 1 } + @{ $options->{annotations} } + ], + filenames => { + map { $_ => do { (my $f = $_) =~ s/\W/-/g; $f } } @{ $options->{file} } + }, + exists => { map { $_ => -e } @{ $options->{file} } }, + get_summary => \&get_summary, + c0 => $le->($options->{report_c0}), + c1 => $le->($options->{report_c1}), + c2 => $le->($options->{report_c2}), + c3 => $ge->($options->{report_c2}), + ); + + write_file $R{options}{outputdir}, "all"; + + for (@{ $options->{file} }) { + $R{file} = $_; + $R{file_link} = "$R{filenames}{$_}.html"; + $R{file_html} = "$options->{outputdir}/$R{file_link}"; + my $show = $options->{show}; + print_file; + print_branches if $show->{branch}; + print_conditions if $show->{condition}; + print_subroutines if $show->{subroutine} || $show->{pod}; + } + + my $html = print_summary; + print "HTML output written to $html\n" unless $options->{silent}; } 1; @@ -472,10 +463,10 @@ use base "Template::Provider"; my %Templates; sub fetch { - my $self = shift; - my ($name) = @_; - # print "Looking for <$name>\n"; - $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name) + my $self = shift; + my ($name) = @_; + # print "Looking for <$name>\n"; + $self->SUPER::fetch(exists $Templates{$name} ? \$Templates{$name} : $name) } $Templates{html} = <<'EOT'; @@ -485,7 +476,7 @@ $Templates{html} = <<'EOT'; ", Dumper $self->{changes}; - open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!"; - while (!eof T) { - my $t = $change_line->(sub { }); - my $c = $change_line->(sub { shift @{$self->{cover}} }); - # print STDERR "[$t]\n[$c]\n" if $t ne $c; - do { - chomp(my $tn = $t); chomp(my $cn = $c); - print STDERR "c-[$tn] $.\ng=[$cn]\n"; - } if $self->{debug}; - - if ($self->{differences}) { - push @at, $t; - push @ac, $c; - } else { - $self->{no_coverage} ? pass : is($t, $c); - last if $self->{no_coverage} && !@{$self->{cover}}; - } + my $self = shift; + + my $cover_com = $self->cover_command; + print STDERR "Running cover [$cover_com]\n" if $self->{debug}; + + my (@at, @ac); + my $change_line = sub { + my ($get_line) = @_; + local *_; + LOOP: while (1) { + $_ = scalar $get_line->(); + $_ = "" unless defined $_; + print STDERR $_ if $self->{debug}; + redo if /^Devel::Cover: merging run/; + redo if /^Set up gcc environment/; # for MinGW + if (/Can't opendir\(.+\): No such file or directory/) { + # parallel tests + scalar $get_line->(); + redo; + } + s/^(Reading database from ).*/$1/; + s|(__ANON__\[) .* (/tests/ \w+ : \d+ \])|$1$2|x; + s/(Subroutine) +(Location)/$1 $2/; + s/-+/-/; + # s/.* Devel-Cover - \d+ \. \d+ \/*(\S+)\s*/$1/x; + s/^ \.\.\. .* - \d+ \. \d+ \/*(\S+)\s*/$1/x; + s/.* Devel \/ Cover \/*(\S+)\s*/$1/x; + s/^(Devel::Cover: merging run).*/$1/; + s/^(Run: ).*/$1/; + s/^(OS: ).*/$1/; + s/^(Perl version: ).*/$1/; + s/^(Start: ).*/$1/; + s/^(Finish: ).*/$1/; + s/copyright .*//ix; + no warnings "exiting"; + eval join "; ", @{ $self->{changes} }; + return $_; } + }; + + # use Devel::Cover::Dumper; print STDERR "--->", Dumper $self->{changes}; + open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!"; + while (!eof T) { + my $t = $change_line->(sub { }); + my $c = $change_line->(sub { shift @{ $self->{cover} } }); + # print STDERR "[$t]\n[$c]\n" if $t ne $c; + do { + chomp(my $tn = $t); + chomp(my $cn = $c); + print STDERR "c-[$tn] $.\ng=[$cn]\n"; + } if $self->{debug}; + if ($self->{differences}) { - no warnings "redefine"; - local *Test::_quote = sub { "@_" }; - $self->{no_coverage} ? pass : eq_or_diff(\@at, \@ac, "output", { context => 0 }); - } elsif ($self->{no_coverage}) { - pass for @{$self->{cover}}; + push @at, $t; + push @ac, $c; + } else { + $self->{no_coverage} ? pass : is($t, $c); + last if $self->{no_coverage} && !@{ $self->{cover} }; } - close T or die "Cannot close $cover_com: $!"; - - 1 + } + if ($self->{differences}) { + no warnings "redefine"; + local *Test::_quote = sub { "@_" }; + $self->{no_coverage} + ? pass + : eq_or_diff(\@at, \@ac, "output", { context => 0 }); + } elsif ($self->{no_coverage}) { + pass for @{ $self->{cover} }; + } + close T or die "Cannot close $cover_com: $!"; + + 1 } sub create_gold { - my $self = shift; - - # Pod::Coverage not available on all versions, but it must be there on - # 5.12.0 - return if $self->{criteria} =~ /\bpod\b/ && $] != 5.012000; + my $self = shift; - my ($base, $v) = $self->cover_gold; - my $gold = "$base.$v"; - my $new_gold = "$base.$]"; - my $gv = $v; - my $ng = ""; + # Pod::Coverage not available on all versions, but it must be there on + # 5.12.0 + return if $self->{criteria} =~ /\bpod\b/ && $] != 5.012000; - unless (-e $new_gold) { - open my $g, ">$new_gold" or die "Can't open $new_gold: $!"; - unlink $new_gold; - } - - # use Devel::Cover::Dumper; print STDERR Dumper $self; - if ($self->{skip}) { - print STDERR "Skipping: $self->{skip}\n"; - return; - } - - $self->{run_test} - ? $self->{run_test}->($self) - : $self->run_command($self->test_command); - - my $cover_com = $self->cover_command; - print STDERR "Running cover [$cover_com]\n" if $self->{debug}; - - open G, ">$new_gold" or die "Cannot open $new_gold: $!"; - open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!"; - while (my $l = ) { - next if $l =~ /^Devel::Cover: merging run/; - $l =~ s/^($_: ).*$/$1.../ - for "Run", "Perl version", "OS", "Start", "Finish"; - $l =~ s/^(Reading database from ).*$/$1.../; - print STDERR $l if $self->{debug}; - print G $l; - $ng .= $l; - } - close T or die "Cannot close $cover_com: $!"; - close G or die "Cannot close $new_gold: $!"; - - print STDERR "gv is $gv and this is $]\n" if $self->{debug}; - print STDERR "gold is $gold and new_gold is $new_gold\n" if $self->{debug}; - unless ($gv eq "0" || $gv eq $]) { - open G, "$gold" or die "Cannot open $gold: $!"; - my $g = do { local $/; }; - close G or die "Cannot close $gold: $!"; - - print STDERR "checking $new_gold against $gold\n" if $self->{debug}; - # print "--[$ng]--\n"; - # print "--[$g]--\n"; - if ($ng eq $g) { - print STDERR "matches $v"; - unlink $new_gold; - } else { - print STDERR "new"; - } + my ($base, $v) = $self->cover_gold; + my $gold = "$base.$v"; + my $new_gold = "$base.$]"; + my $gv = $v; + my $ng = ""; + + unless (-e $new_gold) { + open my $g, ">$new_gold" or die "Can't open $new_gold: $!"; + unlink $new_gold; + } + + # use Devel::Cover::Dumper; print STDERR Dumper $self; + if ($self->{skip}) { + print STDERR "Skipping: $self->{skip}\n"; + return; + } + + $self->{run_test} + ? $self->{run_test}->($self) + : $self->run_command($self->test_command); + + my $cover_com = $self->cover_command; + print STDERR "Running cover [$cover_com]\n" if $self->{debug}; + + open G, ">$new_gold" or die "Cannot open $new_gold: $!"; + open T, "$cover_com 2>&1 |" or die "Cannot run $cover_com: $!"; + while (my $l = ) { + next if $l =~ /^Devel::Cover: merging run/; + $l =~ s/^($_: ).*$/$1.../ + for "Run", "Perl version", "OS", "Start", "Finish"; + $l =~ s/^(Reading database from ).*$/$1.../; + print STDERR $l if $self->{debug}; + print G $l; + $ng .= $l; + } + close T or die "Cannot close $cover_com: $!"; + close G or die "Cannot close $new_gold: $!"; + + print STDERR "gv is $gv and this is $]\n" if $self->{debug}; + print STDERR "gold is $gold and new_gold is $new_gold\n" if $self->{debug}; + unless ($gv eq "0" || $gv eq $]) { + open G, "$gold" or die "Cannot open $gold: $!"; + my $g = do { local $/; }; + close G or die "Cannot close $gold: $!"; + + print STDERR "checking $new_gold against $gold\n" if $self->{debug}; + # print "--[$ng]--\n"; + # print "--[$g]--\n"; + if ($ng eq $g) { + print STDERR "matches $v"; + unlink $new_gold; + } else { + print STDERR "new"; } + } - $self->{end}->() if $self->{end}; + $self->{end}->() if $self->{end}; - 1 + 1 } 1 @@ -500,7 +499,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Time.pm b/lib/Devel/Cover/Time.pm index 89d39839..03ce6d38 100644 --- a/lib/Devel/Cover/Time.pm +++ b/lib/Devel/Cover/Time.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -14,25 +14,25 @@ use warnings; use base "Devel::Cover::Criterion"; -sub uncoverable { 0 } -sub covered { ${$_[0]} } -sub total { 1 } -sub percentage { ${$_[0]} ? 100 : 0 } -sub error { 0 } +sub uncoverable { 0 } +sub covered { ${ $_[0] } } +sub total { 1 } +sub percentage { ${ $_[0] } ? 100 : 0 } +sub error { 0 } sub calculate_summary { - my $self = shift; - my ($db, $file) = @_; + my $self = shift; + my ($db, $file) = @_; - $db->{summary}{$file}{time}{total} += $$self; - $db->{summary}{Total}{time}{total} += $$self; + $db->{summary}{$file}{time}{total} += $$self; + $db->{summary}{Total}{time}{total} += $$self; } sub calculate_percentage { - my $class = shift; - my ($db, $s) = @_; - my $t = $db->{summary}{Total}{time}{total}; - $s->{percentage} = $t ? $s->{total} * 100 / $t : 100; + my $class = shift; + my ($db, $s) = @_; + my $t = $db->{summary}{Total}{time}{total}; + $s->{percentage} = $t ? $s->{total} * 100 / $t : 100; } 1 @@ -69,7 +69,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Truth_Table.pm b/lib/Devel/Cover/Truth_Table.pm index fc467432..5f1a0641 100644 --- a/lib/Devel/Cover/Truth_Table.pm +++ b/lib/Devel/Cover/Truth_Table.pm @@ -11,15 +11,14 @@ use warnings; # Notes : #------------------------------------------------------------------------------- sub error { - my $self = shift; - my $line = shift; - foreach my $c (@{$self->get($line)}) { - return 1 if $c->error; - } - return; + my $self = shift; + my $line = shift; + foreach my $c (@{ $self->get($line) }) { + return 1 if $c->error; + } + return; } - #------------------------------------------------------------------------------- # Subroutine : branch_coverage() # Purpose : Generate textual representation of branches with/without @@ -27,45 +26,42 @@ sub error { # Notes : #------------------------------------------------------------------------------- sub branch_coverage { - my $self = shift; - my $line = shift; - my @txt; - foreach my $c (@{$self->get($line)}) { - push @txt, ($c->[0][0] ? ' T ' : '---') . - ($c->[0][1] ? ' F ' : '---'); - } - return @txt; + my $self = shift; + my $line = shift; + my @txt; + foreach my $c (@{ $self->get($line) }) { + push @txt, ($c->[0][0] ? ' T ' : '---') . ($c->[0][1] ? ' F ' : '---'); + } + return @txt; } - #------------------------------------------------------------------------------- # Subroutine : truth_table() # Purpose : Generate truth table(s) for conditional expressions on a line. # Notes : #------------------------------------------------------------------------------- sub truth_table { - my $self = shift; - my $line = shift; - my $c = $self->get($line); - - return if @$c > 16; # Too big - can't get any useful info anyway. - - my @lops; - foreach my $c (@$c) { - my $op = $c->[1]{type}; - my @hit = map {defined() && $_ > 0 ? 1 : 0} @{$c->[0]}; - @hit = reverse @hit if $op =~ /^or_[23]$/; - my $t = { - tt => Devel::Cover::Truth_Table->new_primitive($op, @hit), - cvg => $c->[1], - expr => join(' ', @{$c->[1]}{qw/left op right/}), - }; - push(@lops, $t); - } - return map {[$_->{tt}->sort, $_->{expr}]} merge_lineops(@lops); + my $self = shift; + my $line = shift; + my $c = $self->get($line); + + return if @$c > 16; # Too big - can't get any useful info anyway. + + my @lops; + foreach my $c (@$c) { + my $op = $c->[1]{type}; + my @hit = map { defined() && $_ > 0 ? 1 : 0 } @{ $c->[0] }; + @hit = reverse @hit if $op =~ /^or_[23]$/; + my $t = { + tt => Devel::Cover::Truth_Table->new_primitive($op, @hit), + cvg => $c->[1], + expr => join(' ', @{ $c->[1] }{qw/left op right/}), + }; + push(@lops, $t); + } + return map { [ $_->{tt}->sort, $_->{expr} ] } merge_lineops(@lops); } - #------------------------------------------------------------------------------- # Subroutine : merge_lineops() # Purpose : Merge multiple conditional expressions into composite @@ -73,109 +69,108 @@ sub truth_table { # Notes : #------------------------------------------------------------------------------- sub merge_lineops { - my @ops = @_; - my $rotations; - while ($#ops > 0) { - my $rm; - for (1 .. $#ops) { - if ($ops[0]{expr} eq $ops[$_]{cvg}{left}) { - $ops[$_]{tt}->left_merge($ops[0]{tt}); - $ops[0] = $ops[$_]; - $rm = $_; last; - } - elsif ($ops[0]{expr} eq $ops[$_]{cvg}{right}) { - $ops[$_]{tt}->right_merge($ops[0]{tt}); - $ops[0] = $ops[$_]; - $rm = $_; last; - } - elsif ($ops[$_]{expr} eq $ops[0]{cvg}{left}) { - $ops[0]{tt}->left_merge($ops[$_]{tt}); - $rm = $_; last; - } - elsif ($ops[$_]{expr} eq $ops[0]{cvg}{right}) { - $ops[0]{tt}->right_merge($ops[$_]{tt}); - $rm = $_; last; - } - } - if ($rm) { - splice(@ops, $rm, 1); - $rotations = 0; - } - else { - # First op didn't merge with anything. Rotate @ops in hopes - # of finding something that can be merged. - unshift(@ops, pop @ops); - - # Hmm... we've come full circle and *still* haven't found - # anything to merge. Did the source code have multiple - # statements on the same line? - last if ($rotations++ > $#ops); - } - } - return @ops; + my @ops = @_; + my $rotations; + while ($#ops > 0) { + my $rm; + for (1 .. $#ops) { + if ($ops[0]{expr} eq $ops[$_]{cvg}{left}) { + $ops[$_]{tt}->left_merge($ops[0]{tt}); + $ops[0] = $ops[$_]; + $rm = $_; + last; + } elsif ($ops[0]{expr} eq $ops[$_]{cvg}{right}) { + $ops[$_]{tt}->right_merge($ops[0]{tt}); + $ops[0] = $ops[$_]; + $rm = $_; + last; + } elsif ($ops[$_]{expr} eq $ops[0]{cvg}{left}) { + $ops[0]{tt}->left_merge($ops[$_]{tt}); + $rm = $_; + last; + } elsif ($ops[$_]{expr} eq $ops[0]{cvg}{right}) { + $ops[0]{tt}->right_merge($ops[$_]{tt}); + $rm = $_; + last; + } + } + if ($rm) { + splice(@ops, $rm, 1); + $rotations = 0; + } else { + # First op didn't merge with anything. Rotate @ops in hopes + # of finding something that can be merged. + unshift(@ops, pop @ops); + + # Hmm... we've come full circle and *still* haven't found + # anything to merge. Did the source code have multiple + # statements on the same line? + last if ($rotations++ > $#ops); + } + } + return @ops; } - package Devel::Cover::Truth_Table::Row; use warnings; use strict; sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my @args = @_; - # use Devel::Cover::Dumper; print Dumper \@args; - return bless { - inputs => $args[0], - result => $args[1], - covered => $args[2], - criterion => $args[2], - }, $class; + my $proto = shift; + my $class = ref($proto) || $proto; + my @args = @_; + # use Devel::Cover::Dumper; print Dumper \@args; + return bless { + inputs => $args[0], + result => $args[1], + covered => $args[2], + criterion => $args[2], + }, $class; } sub inputs { - my $self = shift; - return @{$self->{inputs}}; + my $self = shift; + return @{ $self->{inputs} }; } sub leftcol { - my $self = shift; - return $self->{inputs}[0]; + my $self = shift; + return $self->{inputs}[0]; } sub rightcol { - my $self = shift; - return $self->{inputs}[-1]; + my $self = shift; + return $self->{inputs}[-1]; } sub leftelems { - my $self = shift; - my $n = $#{$self->{inputs}}; - return @{$self->{inputs}}[0 .. $n - 1]; + my $self = shift; + my $n = $#{ $self->{inputs} }; + return @{ $self->{inputs} }[ 0 .. $n - 1 ]; } sub rightelems { - my $self = shift; - my $n = $#{$self->{inputs}}; - return @{$self->{inputs}}[1 .. $n]; + my $self = shift; + my $n = $#{ $self->{inputs} }; + return @{ $self->{inputs} }[ 1 .. $n ]; } sub string { - return "@{$_[0]{inputs}}"; + return "@{$_[0]{inputs}}"; } sub result { - return $_[0]{result}; + return $_[0]{result}; } sub covered { - return $_[0]{covered}; + return $_[0]{covered}; } sub error { - return 1; - # TODO - sort out how this should really work, or remove this report - # return $_[0]{error}[$_[1]]; + return 1; + # TODO - sort out how this should really work, or remove this report + # return $_[0]{error}[$_[1]]; } package Devel::Cover::Truth_Table; @@ -189,12 +184,11 @@ use strict; # Notes : Probably best to keep usage of this internal... #------------------------------------------------------------------------------- sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - return bless [@_], $class; + my $proto = shift; + my $class = ref($proto) || $proto; + return bless [@_], $class; } - #------------------------------------------------------------------------------- # Subroutine : new_primitive() # Purpose : Create a new Truth_Table object based on one of the built-in @@ -202,51 +196,48 @@ sub new { # Notes : #------------------------------------------------------------------------------- sub new_primitive { - my ($proto, $type, @coverage) = @_; + my ($proto, $type, @coverage) = @_; - my %table = ( - and_2 => \&boolean_tt, - and_3 => \&and_tt, - or_2 => \&boolean_tt, - or_3 => \&or_tt, - xor_4 => \&xor_tt, - ); + my %table = ( + and_2 => \&boolean_tt, + and_3 => \&and_tt, + or_2 => \&boolean_tt, + or_3 => \&or_tt, + xor_4 => \&xor_tt, + ); - return $proto->new($table{$type}->(@coverage)); + return $proto->new($table{$type}->(@coverage)); } - #------------------------------------------------------------------------------- # Subroutine : error() # Purpose : Determine if a table is missing full coverage. # Notes : #------------------------------------------------------------------------------- sub error { - my $self = shift; - if (@_) { print "[[[", $self->[shift]->error, "]]]\n"; die } - return $self->[shift]->error if @_; - foreach (@$self) { - return 1 if $_->error; - } - return; + my $self = shift; + if (@_) { print "[[[", $self->[shift]->error, "]]]\n"; die } + return $self->[shift]->error if @_; + foreach (@$self) { + return 1 if $_->error; + } + return; } - #------------------------------------------------------------------------------- # Subroutine : percentage() # Purpose : Determine the coverage proportion for a truth table. # Notes : Don't care states (X) count as one path, not two. #------------------------------------------------------------------------------- sub percentage { - my $self = shift; - my ($p, $c) = (scalar @$self, 0); - foreach (@$self) { - $c++ if $_->covered; - } - return ($c == $p) ? 100 : 100 * $c / $p; + my $self = shift; + my ($p, $c) = (scalar @$self, 0); + foreach (@$self) { + $c++ if $_->covered; + } + return ($c == $p) ? 100 : 100 * $c / $p; } - # Basic truth table constructors # Construct a new truth table for 'A B' coverage listing # primitives. More complicated tables are constructed by merging @@ -264,62 +255,72 @@ sub percentage { # 1 | 1 | 1 | 1 # sub and_tt { - return(Devel::Cover::Truth_Table::Row->new([0, 'X'], 0, shift), - Devel::Cover::Truth_Table::Row->new([1, 0 ], 0, shift), - Devel::Cover::Truth_Table::Row->new([1, 1 ], 1, shift)); + return ( + Devel::Cover::Truth_Table::Row->new([ 0, 'X' ], 0, shift), + Devel::Cover::Truth_Table::Row->new([ 1, 0 ], 0, shift), + Devel::Cover::Truth_Table::Row->new([ 1, 1 ], 1, shift) + ); } + sub or_tt { - return(Devel::Cover::Truth_Table::Row->new([0, 0 ], 0, shift), - Devel::Cover::Truth_Table::Row->new([0, 1 ], 1, shift), - Devel::Cover::Truth_Table::Row->new([1, 'X'], 1, shift)); + return ( + Devel::Cover::Truth_Table::Row->new([ 0, 0 ], 0, shift), + Devel::Cover::Truth_Table::Row->new([ 0, 1 ], 1, shift), + Devel::Cover::Truth_Table::Row->new([ 1, 'X' ], 1, shift) + ); } + sub xor_tt { - return(Devel::Cover::Truth_Table::Row->new([0, 0], 0, shift), - Devel::Cover::Truth_Table::Row->new([0, 1], 1, shift), - Devel::Cover::Truth_Table::Row->new([1, 0], 1, shift), - Devel::Cover::Truth_Table::Row->new([1, 1], 0, shift)); + return ( + Devel::Cover::Truth_Table::Row->new([ 0, 0 ], 0, shift), + Devel::Cover::Truth_Table::Row->new([ 0, 1 ], 1, shift), + Devel::Cover::Truth_Table::Row->new([ 1, 0 ], 1, shift), + Devel::Cover::Truth_Table::Row->new([ 1, 1 ], 0, shift) + ); } + sub boolean_tt { - return(Devel::Cover::Truth_Table::Row->new([0], 0, shift), - Devel::Cover::Truth_Table::Row->new([1], 1, shift)); + return ( + Devel::Cover::Truth_Table::Row->new([0], 0, shift), + Devel::Cover::Truth_Table::Row->new([1], 1, shift) + ); } - #------------------------------------------------------------------------------- # Subroutine : sort() # Purpose : Sort a truth table # Notes : #------------------------------------------------------------------------------- sub sort { - my $self = shift; - @$self = sort {$a->string cmp $b->string} @$self; - return $self; + my $self = shift; + @$self = sort { $a->string cmp $b->string } @$self; + return $self; } - #sub rows {return @{$_[0]}} - #------------------------------------------------------------------------------- # Subroutine : text() # Purpose : Formatted text representation of a truth table # Notes : #------------------------------------------------------------------------------- sub text { - my $self = shift; - my $h = 'A'; - my @h = map {$h++} ($self->[0]->inputs); - my $hdr = "@h |exp|hit"; - my @text; - push @text, $hdr, '-' x length($hdr); - foreach (@$self) { - push @text, sprintf("%s | %s |%s", $_->string(), - $_->result(), $_->covered() ? '+++' : '---'); - } - push @text, '-' x length($hdr); - return @text; -} + my $self = shift; + my $h = 'A'; + my @h = map { $h++ } ($self->[0]->inputs); + my $hdr = "@h |exp|hit"; + my @text; + + push @text, $hdr, '-' x length($hdr); + foreach (@$self) { + push @text, + sprintf("%s | %s |%s", + $_->string(), $_->result(), $_->covered() ? '+++' : '---'); + } + push @text, '-' x length($hdr); + return @text; +} #------------------------------------------------------------------------------- # Subroutine : html() @@ -327,28 +328,27 @@ sub text { # Notes : #------------------------------------------------------------------------------- sub html { - my $self = shift; - my @class = (shift || 'uncovered', shift || 'covered'); - my $html = ""; - my $h = 'A'; - for ($self->[0]->inputs) { - $html .= ""; - $h++; - } - $html .= ""; - - my $c = 0; - foreach (@$self) { - my $class = $class[!$_->error($c++) || $_->covered]; - $html .= qq'"; - } - $html .= "
$hdec
'; - $html .= join(qq'', $_->inputs, $_->result); - $html .= "
"; - return $html; + my $self = shift; + my @class = (shift || 'uncovered', shift || 'covered'); + my $html = ""; + my $h = 'A'; + for ($self->[0]->inputs) { + $html .= ""; + $h++; + } + $html .= ""; + + my $c = 0; + foreach (@$self) { + my $class = $class[ !$_->error($c++) || $_->covered ]; + $html .= qq'"; + } + $html .= "
$hdec
'; + $html .= join(qq'', $_->inputs, $_->result); + $html .= "
"; + return $html; } - # Truth table merge routines: # Combine simple truth tables into more complicated ones. # @@ -407,30 +407,40 @@ sub html { # Notes : #------------------------------------------------------------------------------- sub right_merge { - my ($tt1, $tt2) = @_; - - # find the rows of tt2 that have a result of false/true - my @merge = ([grep {! $_->result} @$tt2], [grep {$_->result} @$tt2]); - # if the rightmost column of tt1 is 'X', we don't care what the - # input from tt2 was - my @dontcare = map {'X'} $tt2->[0]->inputs; - - my @tt; - foreach my $row1 (@$tt1) { - if ($row1->rightcol eq 'X') { - push(@tt, Devel::Cover::Truth_Table::Row->new([$row1->leftelems, @dontcare], - $row1->result, $row1->covered)); - } - else { - # expand value from tt1 with rows from tt2 that result in - # that value - foreach my $row2 (@{$merge[$row1->rightcol]}) { - push(@tt, Devel::Cover::Truth_Table::Row->new([$row1->leftelems, $row2->inputs], - $row1->result, $row1->covered && $row2->covered)); - } - } - } - $_[0] = $tt2->new(@tt); + my ($tt1, $tt2) = @_; + + # find the rows of tt2 that have a result of false/true + my @merge = ([ grep { !$_->result } @$tt2 ], [ grep { $_->result } @$tt2 ]); + # if the rightmost column of tt1 is 'X', we don't care what the + # input from tt2 was + my @dontcare = map { 'X' } $tt2->[0]->inputs; + + my @tt; + foreach my $row1 (@$tt1) { + if ($row1->rightcol eq 'X') { + push( + @tt, + Devel::Cover::Truth_Table::Row->new( + [ $row1->leftelems, @dontcare ], + $row1->result, $row1->covered + ) + ); + } else { + # expand value from tt1 with rows from tt2 that result in + # that value + foreach my $row2 (@{ $merge[ $row1->rightcol ] }) { + push( + @tt, + Devel::Cover::Truth_Table::Row->new( + [ $row1->leftelems, $row2->inputs ], + $row1->result, + $row1->covered && $row2->covered + ) + ); + } + } + } + $_[0] = $tt2->new(@tt); } #------------------------------------------------------------------------------- @@ -439,23 +449,28 @@ sub right_merge { # Notes : #------------------------------------------------------------------------------- sub left_merge { - my ($tt1, $tt2) = @_; - - # find the rows of tt2 that have a result of false/true - my @merge = ([grep {! $_->result} @$tt2], [grep {$_->result} @$tt2]); - - my @tt; - foreach my $row1 (@$tt1) { - my $rightmatters = grep {$_ ne 'X'} $row1->rightelems; - foreach my $row2 (@{$merge[$row1->leftcol]}) { - # expand value from tt1 with rows from tt2 that result in - # that value - push(@tt, Devel::Cover::Truth_Table::Row->new([$row2->inputs, $row1->rightelems], - $row1->result, - ($rightmatters) ? $row1->covered && $row2->covered : $row2->covered)); - } - } - $_[0] = $tt2->new(@tt); + my ($tt1, $tt2) = @_; + + # find the rows of tt2 that have a result of false/true + my @merge = ([ grep { !$_->result } @$tt2 ], [ grep { $_->result } @$tt2 ]); + + my @tt; + foreach my $row1 (@$tt1) { + my $rightmatters = grep { $_ ne 'X' } $row1->rightelems; + foreach my $row2 (@{ $merge[ $row1->leftcol ] }) { + # expand value from tt1 with rows from tt2 that result in + # that value + push( + @tt, + Devel::Cover::Truth_Table::Row->new( + [ $row2->inputs, $row1->rightelems ], + $row1->result, + ($rightmatters) ? $row1->covered && $row2->covered : $row2->covered + ) + ); + } + } + $_[0] = $tt2->new(@tt); } 1; diff --git a/lib/Devel/Cover/Tutorial.pod b/lib/Devel/Cover/Tutorial.pod index 24ae920c..08f19c0d 100644 --- a/lib/Devel/Cover/Tutorial.pod +++ b/lib/Devel/Cover/Tutorial.pod @@ -161,7 +161,7 @@ basis for future research. =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Util.pm b/lib/Devel/Cover/Util.pm index 2ab3fe24..d5a4e77d 100644 --- a/lib/Devel/Cover/Util.pm +++ b/lib/Devel/Cover/Util.pm @@ -1,4 +1,4 @@ -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -19,17 +19,17 @@ use base "Exporter"; our @EXPORT_OK = qw( remove_contained_paths ); sub remove_contained_paths { - my ($container, @paths) = @_; + my ($container, @paths) = @_; - # File::Spec's case tolerancy detection on *nix/Mac systems does not - # take actual file system properties into account, but is better than - # trying to normalise paths with per-os logic. On Windows it is - # properly determined per drive. - my ($drive) = File::Spec->splitpath($container); - my $ignore_case = "(?i)"; - $ignore_case = "" if !File::Spec->case_tolerant($drive); + # File::Spec's case tolerancy detection on *nix/Mac systems does not + # take actual file system properties into account, but is better than + # trying to normalise paths with per-os logic. On Windows it is + # properly determined per drive. + my ($drive) = File::Spec->splitpath($container); + my $ignore_case = "(?i)"; + $ignore_case = "" if !File::Spec->case_tolerant($drive); - my $regex = qr[ + my $regex = qr[ $ignore_case # ignore case on tolerant filesystems ^ # string to match starts with: \Q$container\E # path, meta-quoted for safety @@ -38,12 +38,12 @@ sub remove_contained_paths { # similar to the container ]x; - @paths = grep { - my $path = abs_path $_; # normalise backslashes - $path !~ $regex; # check if path is inside the container - } @paths; + @paths = grep { + my $path = abs_path $_; # normalise backslashes + $path !~ $regex; # check if path is inside the container + } @paths; - return @paths; + return @paths; } 1 @@ -76,7 +76,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/lib/Devel/Cover/Web.pm b/lib/Devel/Cover/Web.pm index 76ef6866..9506fae5 100644 --- a/lib/Devel/Cover/Web.pm +++ b/lib/Devel/Cover/Web.pm @@ -1,4 +1,4 @@ -# Copyright 2007-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2007-2024, Paul Johnson (paul@pjcj.net) # except where otherwise noted. # This software is free. It is licensed under the same terms as Perl itself, @@ -22,18 +22,18 @@ our @EXPORT_OK = "write_file"; my %Files; sub write_file { - my ($directory, $file) = @_; - - while (my ($f, $contents) = each %Files) { - next if - $file ne "all" && - (($file eq "js" || $file eq "css") && $f !~ /\.$file$/) && - $file ne $f; - my $path = "$directory/$f"; - open my $p, ">", $path or next; - print $p $contents; - close $p; - } + my ($directory, $file) = @_; + + while (my ($f, $contents) = each %Files) { + next + if $file ne "all" + && (($file eq "js" || $file eq "css") && $f !~ /\.$file$/) + && $file ne $f; + my $path = "$directory/$f"; + open my $p, ">", $path or next; + print $p $contents; + close $p; + } } $Files{"cover.css"} = <<'EOF'; @@ -926,7 +926,7 @@ Huh? =head1 LICENCE -Copyright 2007-2023, Paul Johnson (paul@pjcj.net) except where otherwise noted. +Copyright 2007-2024, Paul Johnson (paul@pjcj.net) except where otherwise noted. This software is free. It is licensed under the same terms as Perl itself, except where otherwise noted. diff --git a/test_output/cover/accessor.5.012000 b/test_output/cover/accessor.5.012000 index c747e549..5a9e7f0f 100644 --- a/test_output/cover/accessor.5.012000 +++ b/test_output/cover/accessor.5.012000 @@ -20,15 +20,16 @@ tests/Accessor_maker.pm line err stmt bran cond sub code 1 package Accessor_maker; -2 sub import { -3 1 1 no strict 'refs'; +2 +3 sub import { +4 1 1 no strict 'refs'; 1 1 -4 4 4 *{ caller() . '::' . 'foo' } = sub { $_[0]->{ 'foo' } }; +5 4 4 *{ caller() . '::' . 'foo' } = sub { $_[0]->{'foo'} }; 1 1 1 -5 } -6 1; +6 } +7 1; Covered Subroutines @@ -36,9 +37,9 @@ Covered Subroutines Subroutine Count Location ---------- ----- ------------------------- -BEGIN 1 tests/Accessor_maker.pm:3 -__ANON__ 4 tests/Accessor_maker.pm:4 -import 1 tests/Accessor_maker.pm:4 +BEGIN 1 tests/Accessor_maker.pm:4 +__ANON__ 4 tests/Accessor_maker.pm:5 +import 1 tests/Accessor_maker.pm:5 tests/accessor diff --git a/test_output/cover/alias.5.012000 b/test_output/cover/alias.5.012000 index ccc96cf3..51edb20a 100644 --- a/test_output/cover/alias.5.012000 +++ b/test_output/cover/alias.5.012000 @@ -20,7 +20,7 @@ tests/alias line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/alias1.5.012000 b/test_output/cover/alias1.5.012000 index a2f3dfac..fc8b5335 100644 --- a/test_output/cover/alias1.5.012000 +++ b/test_output/cover/alias1.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/Alias1.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -39,14 +39,14 @@ line err stmt bran cond sub code 1 1 14 -15 our @ISA = qw(Exporter); +15 our @ISA = qw(Exporter); 16 our @EXPORT = qw(is_3digits); 17 18 sub is_3digits { -19 2 2 my $val = shift; -20 2 my $retval = undef; -21 2 100 $retval=1 if $val =~ /^\d{3}$/; -22 2 return $retval; +19 2 2 my $val = shift; +20 2 my $retval = undef; +21 2 100 $retval = 1 if $val =~ /^\d{3}$/; +22 2 return $retval; 23 } 24 25 1; @@ -76,7 +76,7 @@ tests/alias1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/and.5.012000 b/test_output/cover/and.5.012000 index 3abca8ce..fc3a0f64 100644 --- a/test_output/cover/and.5.012000 +++ b/test_output/cover/and.5.012000 @@ -20,7 +20,7 @@ tests/and line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2013-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/bigint.5.032000 b/test_output/cover/bigint.5.032000 index 85d7f387..313d1d32 100644 --- a/test_output/cover/bigint.5.032000 +++ b/test_output/cover/bigint.5.032000 @@ -20,7 +20,7 @@ tests/bigint line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2012-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/branch_return_sub.5.012000 b/test_output/cover/branch_return_sub.5.012000 index 17169bdf..b113adb4 100644 --- a/test_output/cover/branch_return_sub.5.012000 +++ b/test_output/cover/branch_return_sub.5.012000 @@ -20,7 +20,7 @@ tests/branch_return_sub line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/change.5.012000 b/test_output/cover/change.5.012000 index 0c7df8a3..7c116a2c 100644 --- a/test_output/cover/change.5.012000 +++ b/test_output/cover/change.5.012000 @@ -27,7 +27,7 @@ tests/change line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_and.5.012000 b/test_output/cover/cond_and.5.012000 index d5f84014..e11c0561 100644 --- a/test_output/cover/cond_and.5.012000 +++ b/test_output/cover/cond_and.5.012000 @@ -20,7 +20,7 @@ tests/cond_and line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_branch.5.012000 b/test_output/cover/cond_branch.5.012000 index 47e4d016..21f09d3b 100644 --- a/test_output/cover/cond_branch.5.012000 +++ b/test_output/cover/cond_branch.5.012000 @@ -20,7 +20,7 @@ tests/cond_branch line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_branch.5.014000 b/test_output/cover/cond_branch.5.014000 index 05789d73..09355ff4 100644 --- a/test_output/cover/cond_branch.5.014000 +++ b/test_output/cover/cond_branch.5.014000 @@ -20,7 +20,7 @@ tests/cond_branch line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_branch.5.016000 b/test_output/cover/cond_branch.5.016000 index b0940e7c..cfda9d7c 100644 --- a/test_output/cover/cond_branch.5.016000 +++ b/test_output/cover/cond_branch.5.016000 @@ -20,7 +20,7 @@ tests/cond_branch line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_branch.5.018000 b/test_output/cover/cond_branch.5.018000 index 950c4cd4..c680a93c 100644 --- a/test_output/cover/cond_branch.5.018000 +++ b/test_output/cover/cond_branch.5.018000 @@ -20,7 +20,7 @@ tests/cond_branch line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_or.5.012000 b/test_output/cover/cond_or.5.012000 index 2e0ef515..98c3fe93 100644 --- a/test_output/cover/cond_or.5.012000 +++ b/test_output/cover/cond_or.5.012000 @@ -21,7 +21,7 @@ tests/cond_or line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 @@ -197,7 +197,7 @@ tests/cond_or.pl line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_or.5.022000 b/test_output/cover/cond_or.5.022000 index b32bbb51..8bc464cf 100644 --- a/test_output/cover/cond_or.5.022000 +++ b/test_output/cover/cond_or.5.022000 @@ -21,7 +21,7 @@ tests/cond_or line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 @@ -197,7 +197,7 @@ tests/cond_or.pl line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_or.5.037005 b/test_output/cover/cond_or.5.038000 similarity index 98% rename from test_output/cover/cond_or.5.037005 rename to test_output/cover/cond_or.5.038000 index bd26b301..2c6c3ce3 100644 --- a/test_output/cover/cond_or.5.037005 +++ b/test_output/cover/cond_or.5.038000 @@ -21,7 +21,7 @@ tests/cond_or line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 @@ -197,7 +197,7 @@ tests/cond_or.pl line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cond_xor.5.012000 b/test_output/cover/cond_xor.5.012000 index bfef41c4..d90199e6 100644 --- a/test_output/cover/cond_xor.5.012000 +++ b/test_output/cover/cond_xor.5.012000 @@ -20,7 +20,7 @@ tests/cond_xor line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/cop.5.012000 b/test_output/cover/cop.5.012000 index 3bba4478..3a7aaccc 100644 --- a/test_output/cover/cop.5.012000 +++ b/test_output/cover/cop.5.012000 @@ -20,7 +20,7 @@ tests/cop line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2011-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/dbm_cond.5.012000 b/test_output/cover/dbm_cond.5.012000 deleted file mode 100644 index 15c0efac..00000000 --- a/test_output/cover/dbm_cond.5.012000 +++ /dev/null @@ -1,105 +0,0 @@ -Reading database from ... - - --------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total --------------- ------ ------ ------ ------ ------ -tests/dbm_cond 100.0 100.0 n/a 100.0 100.0 -Total 100.0 100.0 n/a 100.0 100.0 --------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/dbm_cond - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.008005 || !(eval "use DBM::Deep; 23") -11 # __COVER__ skip_reason DBM::Deep not available -12 -13 1 1 use strict; - 1 - 1 -14 1 1 use warnings; - 1 - 1 -15 -16 1 1 use Test::More; - 1 - 1 -17 -18 1 1 use DBM::Deep; - 1 - 1 -19 -20 1 my $db = DBM::Deep->new( "temp.db" ); -21 1 $db->{1} = 1; -22 -23 1 my $h = { 1 => 1 }; -24 -25 sub testdbm { -26 2 2 my ( $p ) = @_; -27 -28 2 100 if( exists $db->{$p} ) { -29 1 return "dbm: exists"; -30 } else { -31 1 return "dbm: does not exist"; -32 } -33 } -34 -35 sub testh { -36 2 2 my ( $p ) = @_; -37 -38 2 100 if( exists $h->{$p} ) { -39 1 return "h: exists"; -40 } else { -41 1 return "h: does not exist"; -42 } -43 } -44 -45 1 is( testdbm( 1 ), "dbm: exists", "key exists in dbm" ); -46 1 is( testdbm( 2 ), "dbm: does not exist", "key does not exist in dbm" ); -47 -48 1 is( testh( 1 ), "h: exists", "key exists in h" ); -49 1 is( testh( 2 ), "h: does not exist", "key does not exist in h" ); -50 -51 1 unlink "temp.db"; -52 -53 1 done_testing(); - - -Branches --------- - -line err % true false branch ------ --- ------ ------ ------ ------ -28 100 1 1 if (exists $$db{$p}) { } -38 100 1 1 if (exists $$h{$p}) { } - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ----------------- -BEGIN 1 tests/dbm_cond:13 -BEGIN 1 tests/dbm_cond:14 -BEGIN 1 tests/dbm_cond:16 -BEGIN 1 tests/dbm_cond:18 -testdbm 2 tests/dbm_cond:26 -testh 2 tests/dbm_cond:36 - - diff --git a/test_output/cover/dbm_cond.5.022000 b/test_output/cover/dbm_cond.5.022000 deleted file mode 100644 index f6de2af6..00000000 --- a/test_output/cover/dbm_cond.5.022000 +++ /dev/null @@ -1,105 +0,0 @@ -Reading database from ... - - --------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total --------------- ------ ------ ------ ------ ------ -tests/dbm_cond 100.0 100.0 n/a 100.0 100.0 -Total 100.0 100.0 n/a 100.0 100.0 --------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/dbm_cond - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.008005 || !(eval "use DBM::Deep; 23") -11 # __COVER__ skip_reason DBM::Deep not available -12 -13 1 1 use strict; - 1 - 1 -14 1 1 use warnings; - 1 - 1 -15 -16 1 1 use Test::More; - 1 - 1 -17 -18 1 1 use DBM::Deep; - 1 - 1 -19 -20 1 my $db = DBM::Deep->new( "temp.db" ); -21 1 $db->{1} = 1; -22 -23 1 my $h = { 1 => 1 }; -24 -25 sub testdbm { -26 2 2 my ( $p ) = @_; -27 -28 2 100 if( exists $db->{$p} ) { -29 1 return "dbm: exists"; -30 } else { -31 1 return "dbm: does not exist"; -32 } -33 } -34 -35 sub testh { -36 2 2 my ( $p ) = @_; -37 -38 2 100 if( exists $h->{$p} ) { -39 1 return "h: exists"; -40 } else { -41 1 return "h: does not exist"; -42 } -43 } -44 -45 1 is( testdbm( 1 ), "dbm: exists", "key exists in dbm" ); -46 1 is( testdbm( 2 ), "dbm: does not exist", "key does not exist in dbm" ); -47 -48 1 is( testh( 1 ), "h: exists", "key exists in h" ); -49 1 is( testh( 2 ), "h: does not exist", "key does not exist in h" ); -50 -51 1 unlink "temp.db"; -52 -53 1 done_testing(); - - -Branches --------- - -line err % true false branch ------ --- ------ ------ ------ ------ -28 100 1 1 if (exists $db->{$p}) { } -38 100 1 1 if (exists $h->{$p}) { } - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ----------------- -BEGIN 1 tests/dbm_cond:13 -BEGIN 1 tests/dbm_cond:14 -BEGIN 1 tests/dbm_cond:16 -BEGIN 1 tests/dbm_cond:18 -testdbm 2 tests/dbm_cond:26 -testh 2 tests/dbm_cond:36 - - diff --git a/test_output/cover/default_param.5.012000 b/test_output/cover/default_param.5.012000 index c9e0ffef..859b959f 100644 --- a/test_output/cover/default_param.5.012000 +++ b/test_output/cover/default_param.5.012000 @@ -20,7 +20,7 @@ tests/default_param line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/default_param.5.014000 b/test_output/cover/default_param.5.014000 index ddfa445a..84c608be 100644 --- a/test_output/cover/default_param.5.014000 +++ b/test_output/cover/default_param.5.014000 @@ -20,7 +20,7 @@ tests/default_param line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/deparse.5.012000 b/test_output/cover/deparse.5.012000 index bcd99148..af9dcba0 100644 --- a/test_output/cover/deparse.5.012000 +++ b/test_output/cover/deparse.5.012000 @@ -20,7 +20,7 @@ tests/deparse line err stmt bran cond sub code 1 #!/usr/bin/perl -l 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/destroy.5.012000 b/test_output/cover/destroy.5.012000 index 2fa00905..8c51f6d4 100644 --- a/test_output/cover/destroy.5.012000 +++ b/test_output/cover/destroy.5.012000 @@ -20,7 +20,7 @@ tests/destroy line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/dynamic_subs.5.012000 b/test_output/cover/dynamic_subs.5.012000 index 7c5a81ca..f5df3c64 100644 --- a/test_output/cover/dynamic_subs.5.012000 +++ b/test_output/cover/dynamic_subs.5.012000 @@ -20,7 +20,7 @@ tests/dynamic_subs line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval1.5.012000 b/test_output/cover/eval1.5.012000 index 7a048cd9..25762315 100644 --- a/test_output/cover/eval1.5.012000 +++ b/test_output/cover/eval1.5.012000 @@ -20,7 +20,7 @@ tests/eval1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval2.5.012000 b/test_output/cover/eval2.5.012000 index 94a70f99..e7906aa6 100644 --- a/test_output/cover/eval2.5.012000 +++ b/test_output/cover/eval2.5.012000 @@ -20,7 +20,7 @@ Finish: ... tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -47,7 +47,7 @@ E3 0 tests/E3.pm:12 tests/E4.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -76,7 +76,7 @@ tests/eval2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval3.5.012000 b/test_output/cover/eval3.5.012000 index b311a93b..fe21147c 100644 --- a/test_output/cover/eval3.5.012000 +++ b/test_output/cover/eval3.5.012000 @@ -20,7 +20,7 @@ tests/eval3 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_merge.5.012000 b/test_output/cover/eval_merge.5.012000 index b9058f3d..3681d94a 100644 --- a/test_output/cover/eval_merge.5.012000 +++ b/test_output/cover/eval_merge.5.012000 @@ -20,7 +20,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -47,7 +47,7 @@ E2 1 tests/E2.pm:12 tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -76,7 +76,7 @@ tests/eval_merge line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_merge.t.5.012000 b/test_output/cover/eval_merge.t.5.012000 index 0c513840..9aae3c24 100644 --- a/test_output/cover/eval_merge.t.5.012000 +++ b/test_output/cover/eval_merge.t.5.012000 @@ -27,7 +27,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -54,7 +54,7 @@ E2 1 tests/E2.pm:12 tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -81,7 +81,7 @@ E3 2 tests/E3.pm:12 tests/E4.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -110,7 +110,7 @@ tests/eval_merge line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_merge_0.5.012000 b/test_output/cover/eval_merge_0.5.012000 index 9fbc8591..c91a5d23 100644 --- a/test_output/cover/eval_merge_0.5.012000 +++ b/test_output/cover/eval_merge_0.5.012000 @@ -20,7 +20,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -47,7 +47,7 @@ E2 1 tests/E2.pm:12 tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -76,7 +76,7 @@ tests/eval_merge_0 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_merge_1.5.012000 b/test_output/cover/eval_merge_1.5.012000 index 4ab69a67..e455cd2c 100644 --- a/test_output/cover/eval_merge_1.5.012000 +++ b/test_output/cover/eval_merge_1.5.012000 @@ -20,7 +20,7 @@ Finish: ... tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -47,7 +47,7 @@ E3 1 tests/E3.pm:12 tests/E4.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -76,7 +76,7 @@ tests/eval_merge_1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_merge_sep.t.5.012000 b/test_output/cover/eval_merge_sep.t.5.012000 index f26470ca..2deece3c 100644 --- a/test_output/cover/eval_merge_sep.t.5.012000 +++ b/test_output/cover/eval_merge_sep.t.5.012000 @@ -28,7 +28,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -55,7 +55,7 @@ E2 1 tests/E2.pm:12 tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -82,7 +82,7 @@ E3 2 tests/E3.pm:12 tests/E4.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -111,7 +111,7 @@ tests/eval_merge_0 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 @@ -148,7 +148,7 @@ tests/eval_merge_1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_nested.5.012000 b/test_output/cover/eval_nested.5.012000 index 8aa85013..aa51e55f 100644 --- a/test_output/cover/eval_nested.5.012000 +++ b/test_output/cover/eval_nested.5.012000 @@ -20,7 +20,7 @@ tests/eval_nested line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2011-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_sub.t.5.012000 b/test_output/cover/eval_sub.t.5.012000 index cb8b00ba..cb420739 100644 --- a/test_output/cover/eval_sub.t.5.012000 +++ b/test_output/cover/eval_sub.t.5.012000 @@ -38,7 +38,7 @@ tests/eval3 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/eval_use.t.5.012000 b/test_output/cover/eval_use.t.5.012000 index f9adbac8..c4bb5195 100644 --- a/test_output/cover/eval_use.t.5.012000 +++ b/test_output/cover/eval_use.t.5.012000 @@ -39,7 +39,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -66,7 +66,7 @@ E2 0 tests/E2.pm:12 tests/E3.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -93,7 +93,7 @@ E3 0 tests/E3.pm:12 tests/E4.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -122,7 +122,7 @@ tests/eval2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/exec.5.012000 b/test_output/cover/exec.5.012000 index 7d2c75cd..67d6d298 100644 --- a/test_output/cover/exec.5.012000 +++ b/test_output/cover/exec.5.012000 @@ -20,7 +20,7 @@ tests/exec line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2007-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2007-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/exec_die.5.012000 b/test_output/cover/exec_die.5.012000 index 2981f2da..2ae7ce68 100644 --- a/test_output/cover/exec_die.5.012000 +++ b/test_output/cover/exec_die.5.012000 @@ -20,7 +20,7 @@ tests/exec_die line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2011-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/fork.5.012000 b/test_output/cover/fork.5.012000 index 6ab37932..eca4a59e 100644 --- a/test_output/cover/fork.5.012000 +++ b/test_output/cover/fork.5.012000 @@ -26,7 +26,7 @@ tests/fork line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/if.5.012000 b/test_output/cover/if.5.012000 index 7b47325e..da6f77eb 100644 --- a/test_output/cover/if.5.012000 +++ b/test_output/cover/if.5.012000 @@ -20,7 +20,7 @@ tests/if line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/md5.5.012000 b/test_output/cover/md5.5.012000 index 26758a4b..4accc1da 100644 --- a/test_output/cover/md5.5.012000 +++ b/test_output/cover/md5.5.012000 @@ -27,7 +27,7 @@ tests/md5 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module1.5.012000 b/test_output/cover/module1.5.012000 index ccbb22c2..69ef41fe 100644 --- a/test_output/cover/module1.5.012000 +++ b/test_output/cover/module1.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/Module1.pm line err stmt bran cond sub code -1 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -32,23 +32,23 @@ line err stmt bran cond sub code 11 $y++; 12 13 sub _aa { -14 *** *0 *0 $y++; -15 *** *0 die; -16 *** *0 die; +14 *** *0 *0 $y++; +15 *** *0 die; +16 *** *0 die; 17 } 18 19 sub xx { -20 *** *0 *0 $y++; -21 *** *0 die; +20 *** *0 *0 $y++; +21 *** *0 die; 22 } 23 24 sub yy { -25 *** *0 *0 $y++; +25 *** *0 *0 $y++; 26 } 27 28 sub zz { -29 11 11 my $x = shift; -30 11 $x++; +29 11 11 my $x = shift; +30 11 $x++; 31 } 32 33 1 @@ -78,7 +78,7 @@ tests/module1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module2.5.012000 b/test_output/cover/module2.5.012000 index 4788566e..84febeff 100644 --- a/test_output/cover/module2.5.012000 +++ b/test_output/cover/module2.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/Module2.pm line err stmt bran cond sub code -1 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -32,23 +32,23 @@ line err stmt bran cond sub code 11 $y++; 12 13 sub _aa { -14 *** *0 *0 $y++; -15 *** *0 die; -16 *** *0 die; +14 *** *0 *0 $y++; +15 *** *0 die; +16 *** *0 die; 17 } 18 19 sub _xx { -20 *** *0 *0 $y++; -21 *** *0 die; +20 *** *0 *0 $y++; +21 *** *0 die; 22 } 23 24 sub yy { -25 *** *0 *0 $y++; +25 *** *0 *0 $y++; 26 } 27 28 sub zz { -29 11 11 my $x = shift; -30 11 $x++; +29 11 11 my $x = shift; +30 11 $x++; 31 } 32 33 1 @@ -78,7 +78,7 @@ tests/module2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module_ignore.5.012000 b/test_output/cover/module_ignore.5.012000 index bdfd01dc..988a3207 100644 --- a/test_output/cover/module_ignore.5.012000 +++ b/test_output/cover/module_ignore.5.012000 @@ -20,7 +20,7 @@ tests/module_ignore line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2006-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module_import.5.012000 b/test_output/cover/module_import.5.012000 index 7b3c6b47..7e5d2904 100644 --- a/test_output/cover/module_import.5.012000 +++ b/test_output/cover/module_import.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/Module_import.pm line err stmt bran cond sub code -1 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -29,7 +29,7 @@ line err stmt bran cond sub code 8 package Module_import; 9 10 sub import { -11 1 1 print "Module_import\n"; +11 1 1 print "Module_import\n"; 12 } 13 14 1 @@ -48,7 +48,7 @@ tests/module_import line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module_relative.5.012000 b/test_output/cover/module_relative.5.012000 index 236bddcc..489bba21 100644 --- a/test_output/cover/module_relative.5.012000 +++ b/test_output/cover/module_relative.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/Module_import.pm line err stmt bran cond sub code -1 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -29,7 +29,7 @@ line err stmt bran cond sub code 8 package Module_import; 9 10 sub import { -11 1 1 print "Module_import\n"; +11 1 1 print "Module_import\n"; 12 } 13 14 1 @@ -48,7 +48,7 @@ tests/module_relative line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/module_statements.5.012000 b/test_output/cover/module_statements.5.012000 index 32ba3bae..be8f15c0 100644 --- a/test_output/cover/module_statements.5.012000 +++ b/test_output/cover/module_statements.5.012000 @@ -20,7 +20,7 @@ tests/module_statements line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/moo_cond.5.012000 b/test_output/cover/moo_cond.5.012000 deleted file mode 100644 index daa8c2bc..00000000 --- a/test_output/cover/moo_cond.5.012000 +++ /dev/null @@ -1,77 +0,0 @@ -Reading database from ... - - --------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total --------------- ------ ------ ------ ------ ------ -tests/moo_cond 100.0 100.0 n/a 100.0 100.0 -Total 100.0 100.0 n/a 100.0 100.0 --------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moo_cond - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.008002 || !(eval "use Moo 1.000003; 23") -11 # __COVER__ skip_reason Moo not available -12 -13 1 1 use strict; - 1 - 1 -14 1 1 use warnings; - 1 - 1 -15 -16 package Cover_branch_bug_Moo; -17 -18 1 1 use Moo; - 1 - 1 -19 -20 1 has config => ( is => 'lazy' ); -21 1 has config2 => ( is => 'ro' ); -22 -23 1 __PACKAGE__->new( config => {}, config2 => {} )->trigger; -24 1 __PACKAGE__->new( config => {debug => 1}, config2 => {debug => 1} )->trigger; -25 -26 sub trigger { -27 2 100 2 1 if $_[0]->config->{debug}; -28 2 100 1 if $_[0]->config2->{debug}; -29 } - - -Branches --------- - -line err % true false branch ------ --- ------ ------ ------ ------ -27 100 1 1 if $_[0]->config->{"debug"} -28 100 1 1 if $_[0]->config2->{"debug"} - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ----------------- -BEGIN 1 tests/moo_cond:13 -BEGIN 1 tests/moo_cond:14 -BEGIN 1 tests/moo_cond:18 -trigger 2 tests/moo_cond:27 - - diff --git a/test_output/cover/moo_cond.5.022000 b/test_output/cover/moo_cond.5.022000 deleted file mode 100644 index 71c6524e..00000000 --- a/test_output/cover/moo_cond.5.022000 +++ /dev/null @@ -1,77 +0,0 @@ -Reading database from ... - - --------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total --------------- ------ ------ ------ ------ ------ -tests/moo_cond 100.0 100.0 n/a 100.0 100.0 -Total 100.0 100.0 n/a 100.0 100.0 --------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moo_cond - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.008002 || !(eval "use Moo 1.000003; 23") -11 # __COVER__ skip_reason Moo not available -12 -13 1 1 use strict; - 1 - 1 -14 1 1 use warnings; - 1 - 1 -15 -16 package Cover_branch_bug_Moo; -17 -18 1 1 use Moo; - 1 - 1 -19 -20 1 has config => ( is => 'lazy' ); -21 1 has config2 => ( is => 'ro' ); -22 -23 1 __PACKAGE__->new( config => {}, config2 => {} )->trigger; -24 1 __PACKAGE__->new( config => {debug => 1}, config2 => {debug => 1} )->trigger; -25 -26 sub trigger { -27 2 100 2 1 if $_[0]->config->{debug}; -28 2 100 1 if $_[0]->config2->{debug}; -29 } - - -Branches --------- - -line err % true false branch ------ --- ------ ------ ------ ------ -27 100 1 1 if $_[0]->config->{'debug'} -28 100 1 1 if $_[0]->config2->{'debug'} - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ----------------- -BEGIN 1 tests/moo_cond:13 -BEGIN 1 tests/moo_cond:14 -BEGIN 1 tests/moo_cond:18 -trigger 2 tests/moo_cond:27 - - diff --git a/test_output/cover/moose_basic.5.012000 b/test_output/cover/moose_basic.5.012000 deleted file mode 100644 index b6764ff5..00000000 --- a/test_output/cover/moose_basic.5.012000 +++ /dev/null @@ -1,47 +0,0 @@ -Reading database from ... - - ------------------ ------ ------ ------ ------ ------ -File stmt bran cond sub total ------------------ ------ ------ ------ ------ ------ -tests/moose_basic 100.0 n/a n/a 100.0 100.0 -Total 100.0 n/a n/a 100.0 100.0 ------------------ ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moose_basic - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") -11 # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover -12 -13 package Foo; -14 1 1 use Moose; - 1 - 1 -15 1 __PACKAGE__->meta->make_immutable; - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- -------------------- -BEGIN 1 tests/moose_basic:14 - - diff --git a/test_output/cover/moose_cond.5.012000 b/test_output/cover/moose_cond.5.012000 deleted file mode 100644 index 2550206e..00000000 --- a/test_output/cover/moose_cond.5.012000 +++ /dev/null @@ -1,84 +0,0 @@ -Reading database from ... - - ----------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total ----------------- ------ ------ ------ ------ ------ -tests/moose_cond 100.0 n/a 75.0 100.0 96.1 -Total 100.0 n/a 75.0 100.0 96.1 ----------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moose_cond - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.010 || !(eval "use Moose 2; 23") -11 # __COVER__ skip_reason Moose 2 not available or unreliable with Devel::Cover -12 -13 1 1 use strict; - 1 - 1 -14 1 1 use warnings; - 1 - 1 -15 -16 package Cover_branch_bug; -17 -18 1 1 use Moose; - 1 - 1 -19 1 has meep => ( isa => 'HashRef', is => 'rw' ); -20 -21 1 my $self = __PACKAGE__->new; -22 -23 1 $self->meep( { marp => 0 } ); -24 1 print "meep contains " . $self->wagh . "\n"; -25 -26 1 $self->meep( { marp => 1 } ); -27 1 print "meep contains " . $self->wagh . "\n"; -28 -29 sub wagh { -30 2 2 my ( $self ) = @_; -31 *** 2 * 50 my $x = $self || 0; -32 2 100 return $self->meep->{marp} || 0; -33 # return $self || 0; -34 } - - -Conditions ----------- - -or 2 conditions - -line err % l !l expr ------ --- ------ ------ ------ ---- -31 *** 50 2 0 $self || 0 -32 100 1 1 $self->meep->{'marp'} || 0 - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ------------------- -BEGIN 1 tests/moose_cond:13 -BEGIN 1 tests/moose_cond:14 -BEGIN 1 tests/moose_cond:18 -wagh 2 tests/moose_cond:30 - - diff --git a/test_output/cover/moose_constraint.5.012000 b/test_output/cover/moose_constraint.5.012000 deleted file mode 100644 index 0ff92c0b..00000000 --- a/test_output/cover/moose_constraint.5.012000 +++ /dev/null @@ -1,66 +0,0 @@ -Reading database from ... - - ----------------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total ----------------------- ------ ------ ------ ------ ------ -tests/moose_constraint 100.0 n/a n/a 100.0 100.0 -Total 100.0 n/a n/a 100.0 100.0 ----------------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moose_constraint - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") -11 # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover -12 -13 1 1 use 5.010; - 1 1 - 1 - 1 - 1 -14 -15 package Foo; -16 -17 1 1 use Moose; - 1 - 1 -18 -19 1 has bar => ( -20 is => 'rw', -21 isa => 'Maybe[Str]', -22 ); -23 -24 package main; -25 -26 1 my $example = Foo->new(); -27 1 $example->bar('whatever'); -28 1 say $example->bar(); - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ------------------------- -BEGIN 1 tests/moose_constraint:13 -BEGIN 1 tests/moose_constraint:13 -BEGIN 1 tests/moose_constraint:17 - - diff --git a/test_output/cover/moose_constraint.5.016000 b/test_output/cover/moose_constraint.5.016000 deleted file mode 100644 index 2e96b9d5..00000000 --- a/test_output/cover/moose_constraint.5.016000 +++ /dev/null @@ -1,62 +0,0 @@ -Reading database from ... - - ----------------------- ------ ------ ------ ------ ------ -File stmt bran cond sub total ----------------------- ------ ------ ------ ------ ------ -tests/moose_constraint 100.0 n/a n/a 100.0 100.0 -Total 100.0 n/a n/a 100.0 100.0 ----------------------- ------ ------ ------ ------ ------ - - -Run: ... -Perl version: ... -OS: ... -Start: ... -Finish: ... - -tests/moose_constraint - -line err stmt bran cond sub code -1 #!/usr/bin/perl -2 -3 # Copyright 2011-2023, Paul Johnson (paul@pjcj.net) -4 -5 # This software is free. It is licensed under the same terms as Perl itself. -6 -7 # The latest version of this software should be available from my homepage: -8 # http://www.pjcj.net -9 -10 # __COVER__ skip_test $] < 5.010 || !(eval "use Moose; 23") -11 # __COVER__ skip_reason Moose not available or unreliable with Devel::Cover -12 -13 1 1 use 5.010; - 1 -14 -15 package Foo; -16 -17 1 1 use Moose; - 1 - 1 -18 -19 1 has bar => ( -20 is => 'rw', -21 isa => 'Maybe[Str]', -22 ); -23 -24 package main; -25 -26 1 my $example = Foo->new(); -27 1 $example->bar('whatever'); -28 1 say $example->bar(); - - -Covered Subroutines -------------------- - -Subroutine Count Location ----------- ----- ------------------------- -BEGIN 1 tests/moose_constraint:13 -BEGIN 1 tests/moose_constraint:17 - - diff --git a/test_output/cover/overload_bool.5.012000 b/test_output/cover/overload_bool.5.012000 index 50e521b3..24a4a14e 100644 --- a/test_output/cover/overload_bool.5.012000 +++ b/test_output/cover/overload_bool.5.012000 @@ -20,7 +20,7 @@ tests/overload_bool line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2006-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/overload_bool2.5.012000 b/test_output/cover/overload_bool2.5.012000 index 4fc03b97..ff903264 100644 --- a/test_output/cover/overload_bool2.5.012000 +++ b/test_output/cover/overload_bool2.5.012000 @@ -20,7 +20,7 @@ tests/overload_bool2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/overload_bool2.5.022000 b/test_output/cover/overload_bool2.5.022000 index 34b67538..c83b74e8 100644 --- a/test_output/cover/overload_bool2.5.022000 +++ b/test_output/cover/overload_bool2.5.022000 @@ -20,7 +20,7 @@ tests/overload_bool2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/overload_bool2.5.037001 b/test_output/cover/overload_bool2.5.038000 similarity index 97% rename from test_output/cover/overload_bool2.5.037001 rename to test_output/cover/overload_bool2.5.038000 index 41558514..91d4fc3a 100644 --- a/test_output/cover/overload_bool2.5.037001 +++ b/test_output/cover/overload_bool2.5.038000 @@ -20,7 +20,7 @@ tests/overload_bool2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2014-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/overloaded.5.012000 b/test_output/cover/overloaded.5.012000 index 188e7ea5..5c98287f 100644 --- a/test_output/cover/overloaded.5.012000 +++ b/test_output/cover/overloaded.5.012000 @@ -20,7 +20,7 @@ tests/overloaded line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2003-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2003-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/padrange.5.012000 b/test_output/cover/padrange.5.012000 index 469d3ee4..272d9094 100644 --- a/test_output/cover/padrange.5.012000 +++ b/test_output/cover/padrange.5.012000 @@ -20,7 +20,7 @@ tests/padrange line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/readonly.5.012000 b/test_output/cover/readonly.5.012000 index 0aa18bb2..1d15280d 100644 --- a/test_output/cover/readonly.5.012000 +++ b/test_output/cover/readonly.5.012000 @@ -20,7 +20,7 @@ tests/readonly line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2012-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/recursive_sub.5.016000 b/test_output/cover/recursive_sub.5.016000 index c91058f5..20b0003a 100644 --- a/test_output/cover/recursive_sub.5.016000 +++ b/test_output/cover/recursive_sub.5.016000 @@ -20,7 +20,7 @@ tests/recursive_sub line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2022-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2022-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/require.5.012000 b/test_output/cover/require.5.012000 index fae8c1da..1ad15aa0 100644 --- a/test_output/cover/require.5.012000 +++ b/test_output/cover/require.5.012000 @@ -19,7 +19,7 @@ Finish: ... tests/E2.pm line err stmt bran cond sub code -1 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +1 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 2 3 # This software is free. It is licensed under the same terms as Perl itself. 4 @@ -48,7 +48,7 @@ tests/require line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/signature.5.032000 b/test_output/cover/signature.5.032000 index 4c3b247e..db8c240f 100644 --- a/test_output/cover/signature.5.032000 +++ b/test_output/cover/signature.5.032000 @@ -20,7 +20,7 @@ tests/signature line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2019-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2019-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/skip.5.012000 b/test_output/cover/skip.5.012000 index 10f07690..d39dfb5b 100644 --- a/test_output/cover/skip.5.012000 +++ b/test_output/cover/skip.5.012000 @@ -20,7 +20,7 @@ tests/skip line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/special_blocks.5.012000 b/test_output/cover/special_blocks.5.012000 index e282561f..bb129464 100644 --- a/test_output/cover/special_blocks.5.012000 +++ b/test_output/cover/special_blocks.5.012000 @@ -20,7 +20,7 @@ tests/special_blocks line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/statement.5.012000 b/test_output/cover/statement.5.012000 index b8e5713e..eba5824c 100644 --- a/test_output/cover/statement.5.012000 +++ b/test_output/cover/statement.5.012000 @@ -20,7 +20,7 @@ tests/statement line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/subs_only.5.012000 b/test_output/cover/subs_only.5.012000 index 5e9bf8db..54b38057 100644 --- a/test_output/cover/subs_only.5.012000 +++ b/test_output/cover/subs_only.5.012000 @@ -20,7 +20,7 @@ tests/subs_only line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2006-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/t0.5.012000 b/test_output/cover/t0.5.012000 index 244f8443..2978f283 100644 --- a/test_output/cover/t0.5.012000 +++ b/test_output/cover/t0.5.012000 @@ -20,7 +20,7 @@ tests/t0 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/t1.5.012000 b/test_output/cover/t1.5.012000 index de3a98f7..c4f20e6c 100644 --- a/test_output/cover/t1.5.012000 +++ b/test_output/cover/t1.5.012000 @@ -20,7 +20,7 @@ tests/t1 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/t2.5.012000 b/test_output/cover/t2.5.012000 index b1472760..080f9ec3 100644 --- a/test_output/cover/t2.5.012000 +++ b/test_output/cover/t2.5.012000 @@ -20,7 +20,7 @@ tests/t2 line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2002-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/taint.5.012000 b/test_output/cover/taint.5.012000 index 0f284f8e..28a21dd8 100644 --- a/test_output/cover/taint.5.012000 +++ b/test_output/cover/taint.5.012000 @@ -20,7 +20,7 @@ tests/taint line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2013-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/trivial.5.012000 b/test_output/cover/trivial.5.012000 index 20d30da0..e86d9c35 100644 --- a/test_output/cover/trivial.5.012000 +++ b/test_output/cover/trivial.5.012000 @@ -20,7 +20,7 @@ tests/trivial line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/uncoverable.5.012000 b/test_output/cover/uncoverable.5.012000 index a140e2e0..4dd990fb 100644 --- a/test_output/cover/uncoverable.5.012000 +++ b/test_output/cover/uncoverable.5.012000 @@ -22,7 +22,7 @@ tests/uncoverable line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/uncoverable_error.5.012000 b/test_output/cover/uncoverable_error.5.012000 index d7c22d89..b7751d1a 100644 --- a/test_output/cover/uncoverable_error.5.012000 +++ b/test_output/cover/uncoverable_error.5.012000 @@ -20,7 +20,7 @@ tests/uncoverable_error line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2023-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/uncoverable_error_ignore.5.012000 b/test_output/cover/uncoverable_error_ignore.5.012000 index ec1f8095..6bd7b540 100644 --- a/test_output/cover/uncoverable_error_ignore.5.012000 +++ b/test_output/cover/uncoverable_error_ignore.5.012000 @@ -20,7 +20,7 @@ tests/uncoverable_error_ignore line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2023-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/test_output/cover/v-58x.5.012000 b/test_output/cover/v-58x.5.012000 index 1c7c225e..b010d02b 100644 --- a/test_output/cover/v-58x.5.012000 +++ b/test_output/cover/v-58x.5.012000 @@ -20,7 +20,7 @@ tests/v-58x line err stmt bran cond sub code 1 #!/usr/bin/perl 2 -3 # Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +3 # Copyright 2004-2024, Paul Johnson (paul@pjcj.net) 4 5 # This software is free. It is licensed under the same terms as Perl itself. 6 diff --git a/tests/Accessor_maker.pm b/tests/Accessor_maker.pm index 2323f803..0a762d58 100644 --- a/tests/Accessor_maker.pm +++ b/tests/Accessor_maker.pm @@ -1,6 +1,7 @@ package Accessor_maker; + sub import { no strict 'refs'; - *{ caller() . '::' . 'foo' } = sub { $_[0]->{ 'foo' } }; + *{ caller() . '::' . 'foo' } = sub { $_[0]->{'foo'} }; } 1; diff --git a/tests/Alias1.pm b/tests/Alias1.pm index 297641a1..fc9296f5 100644 --- a/tests/Alias1.pm +++ b/tests/Alias1.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -12,14 +12,14 @@ use warnings; use Exporter; -our @ISA = qw(Exporter); +our @ISA = qw(Exporter); our @EXPORT = qw(is_3digits); sub is_3digits { - my $val = shift; - my $retval = undef; - $retval=1 if $val =~ /^\d{3}$/; - return $retval; + my $val = shift; + my $retval = undef; + $retval = 1 if $val =~ /^\d{3}$/; + return $retval; } 1; diff --git a/tests/E2.pm b/tests/E2.pm index 8118392b..7b1fec42 100644 --- a/tests/E2.pm +++ b/tests/E2.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/E3.pm b/tests/E3.pm index 312bf821..da919aa8 100644 --- a/tests/E3.pm +++ b/tests/E3.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/E4.pm b/tests/E4.pm index 91f9d5d5..3ad779ec 100644 --- a/tests/E4.pm +++ b/tests/E4.pm @@ -1,4 +1,4 @@ -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/Module1.pm b/tests/Module1.pm index c0dbba7e..da3f829c 100644 --- a/tests/Module1.pm +++ b/tests/Module1.pm @@ -1,4 +1,4 @@ -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -11,23 +11,23 @@ my $y = 7; $y++; sub _aa { - $y++; - die; - die; + $y++; + die; + die; } sub xx { - $y++; - die; + $y++; + die; } sub yy { - $y++; + $y++; } sub zz { - my $x = shift; - $x++; + my $x = shift; + $x++; } 1 diff --git a/tests/Module2.pm b/tests/Module2.pm index 5753636e..4b58a669 100644 --- a/tests/Module2.pm +++ b/tests/Module2.pm @@ -1,4 +1,4 @@ -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -11,23 +11,23 @@ my $y = 7; $y++; sub _aa { - $y++; - die; - die; + $y++; + die; + die; } sub _xx { - $y++; - die; + $y++; + die; } sub yy { - $y++; + $y++; } sub zz { - my $x = shift; - $x++; + my $x = shift; + $x++; } 1 diff --git a/tests/Module_import.pm b/tests/Module_import.pm index 94c894f9..ee77ed00 100644 --- a/tests/Module_import.pm +++ b/tests/Module_import.pm @@ -1,4 +1,4 @@ -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -8,7 +8,7 @@ package Module_import; sub import { - print "Module_import\n"; + print "Module_import\n"; } 1 diff --git a/tests/PodMod.pm b/tests/PodMod.pm index 0a2ec59d..3787be39 100644 --- a/tests/PodMod.pm +++ b/tests/PodMod.pm @@ -1,4 +1,4 @@ -# Copyright 2005-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2005-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/Taint.pm b/tests/Taint.pm index 3f0e72d7..5baba288 100644 --- a/tests/Taint.pm +++ b/tests/Taint.pm @@ -1,4 +1,4 @@ -# Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2013-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/alias b/tests/alias index 01fdeb12..05444816 100644 --- a/tests/alias +++ b/tests/alias @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/alias1 b/tests/alias1 index 2cb90772..0247b167 100644 --- a/tests/alias1 +++ b/tests/alias1 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/and b/tests/and index ad389336..a78222ad 100644 --- a/tests/and +++ b/tests/and @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2013-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/bigint b/tests/bigint index 3d175b5e..e0c87f6a 100644 --- a/tests/bigint +++ b/tests/bigint @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/branch_return_sub b/tests/branch_return_sub index 4627a366..09e64782 100644 --- a/tests/branch_return_sub +++ b/tests/branch_return_sub @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/change.t b/tests/change.t index c1e04c11..022fb82c 100644 --- a/tests/change.t +++ b/tests/change.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cond_and b/tests/cond_and index 34788070..2a191e2f 100644 --- a/tests/cond_and +++ b/tests/cond_and @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cond_branch b/tests/cond_branch index dc10d226..d56911f8 100644 --- a/tests/cond_branch +++ b/tests/cond_branch @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cond_or b/tests/cond_or index 94e531fc..e1d1a752 100644 --- a/tests/cond_or +++ b/tests/cond_or @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cond_or.pl b/tests/cond_or.pl index b470874a..7f48d83f 100644 --- a/tests/cond_or.pl +++ b/tests/cond_or.pl @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cond_xor b/tests/cond_xor index 5162dc78..a2310be3 100644 --- a/tests/cond_xor +++ b/tests/cond_xor @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/cop b/tests/cop index cd20f5db..2952d7bf 100644 --- a/tests/cop +++ b/tests/cop @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/dbm_cond b/tests/dbm_cond index bb5bb38d..b9cd8518 100644 --- a/tests/dbm_cond +++ b/tests/dbm_cond @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/default_param b/tests/default_param index 54a29dd2..119cb5fb 100644 --- a/tests/default_param +++ b/tests/default_param @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/deparse b/tests/deparse index 1a801468..ad258d3a 100644 --- a/tests/deparse +++ b/tests/deparse @@ -1,6 +1,6 @@ #!/usr/bin/perl -l -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/destroy b/tests/destroy index ac60bd43..1b69dc32 100644 --- a/tests/destroy +++ b/tests/destroy @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/dist/DC-Test-Dist/Makefile.PL b/tests/dist/DC-Test-Dist/Makefile.PL index a7fda94d..4d9a1163 100644 --- a/tests/dist/DC-Test-Dist/Makefile.PL +++ b/tests/dist/DC-Test-Dist/Makefile.PL @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm b/tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm index 22008af7..ceb2d7e6 100644 --- a/tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm +++ b/tests/dist/DC-Test-Dist/lib/DC/Test/Dist.pm @@ -1,4 +1,4 @@ -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -15,23 +15,23 @@ use warnings; use DC::Test::Dist::M1; sub new { - bless {}, shift + bless {}, shift } sub d1 { - my $self = shift; - if (@_) { - $self->{d1} = shift; - } - $self->{d1} + my $self = shift; + if (@_) { + $self->{d1} = shift; + } + $self->{d1} } sub d2 { - my $self = shift; - if (@_) { - $self->{d2} = shift; - } - $self->{d2} + my $self = shift; + if (@_) { + $self->{d2} = shift; + } + $self->{d2} } 1 @@ -52,7 +52,7 @@ None. =head1 LICENCE -Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +Copyright 2012-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm b/tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm index 72f1b5d6..3e443093 100644 --- a/tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm +++ b/tests/dist/DC-Test-Dist/lib/DC/Test/Dist/M1.pm @@ -1,4 +1,4 @@ -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -13,23 +13,23 @@ use warnings; # VERSION sub new { - bless {}, shift + bless {}, shift } sub m1 { - my $self = shift; - if (@_) { - $self->{m1} = shift; - } - $self->{m1} + my $self = shift; + if (@_) { + $self->{m1} = shift; + } + $self->{m1} } sub m2 { - my $self = shift; - if (@_) { - $self->{m2} = shift; - } - $self->{m2} + my $self = shift; + if (@_) { + $self->{m2} = shift; + } + $self->{m2} } 1 @@ -50,7 +50,7 @@ None. =head1 LICENCE -Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +Copyright 2012-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/dynamic_subs b/tests/dynamic_subs index 2c55ece2..f690ae10 100644 --- a/tests/dynamic_subs +++ b/tests/dynamic_subs @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/empty b/tests/empty index d3b67216..2ae1fbe1 100644 --- a/tests/empty +++ b/tests/empty @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2015-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2015-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/end_constant b/tests/end_constant index 9f391847..f7f67f1a 100644 --- a/tests/end_constant +++ b/tests/end_constant @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2015-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2015-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval1 b/tests/eval1 index 55c47c3e..faea0187 100644 --- a/tests/eval1 +++ b/tests/eval1 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval2 b/tests/eval2 index 07321346..a095d613 100644 --- a/tests/eval2 +++ b/tests/eval2 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval3 b/tests/eval3 index 7c55ff1e..3f5f5f65 100644 --- a/tests/eval3 +++ b/tests/eval3 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_merge b/tests/eval_merge index 8ad08a4d..ea9525c3 100644 --- a/tests/eval_merge +++ b/tests/eval_merge @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_merge.t b/tests/eval_merge.t index 745e02c8..3ad25f5b 100644 --- a/tests/eval_merge.t +++ b/tests/eval_merge.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_merge_0 b/tests/eval_merge_0 index caffa621..abe9ba97 100644 --- a/tests/eval_merge_0 +++ b/tests/eval_merge_0 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_merge_1 b/tests/eval_merge_1 index 164f4423..935eb33b 100644 --- a/tests/eval_merge_1 +++ b/tests/eval_merge_1 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_merge_sep.t b/tests/eval_merge_sep.t index 6152c854..10f59304 100644 --- a/tests/eval_merge_sep.t +++ b/tests/eval_merge_sep.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_nested b/tests/eval_nested index dbc66420..25880bac 100644 --- a/tests/eval_nested +++ b/tests/eval_nested @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_sub.t b/tests/eval_sub.t index 8afe6440..690f8fd9 100644 --- a/tests/eval_sub.t +++ b/tests/eval_sub.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/eval_use.t b/tests/eval_use.t index 03ad3c2a..e21f5e58 100644 --- a/tests/eval_use.t +++ b/tests/eval_use.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/exec b/tests/exec index 44a19fe7..2476c90e 100644 --- a/tests/exec +++ b/tests/exec @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2007-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2007-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/exec_die b/tests/exec_die index e2549cad..333fafb3 100644 --- a/tests/exec_die +++ b/tests/exec_die @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/final_op b/tests/final_op index 801a5e6d..965440e1 100644 --- a/tests/final_op +++ b/tests/final_op @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2015-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2015-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/fork b/tests/fork index 3939bc9b..30348d6e 100644 --- a/tests/fork +++ b/tests/fork @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/if b/tests/if index 95fde7f5..f480f381 100644 --- a/tests/if +++ b/tests/if @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/inc_sub b/tests/inc_sub index 4b9e2bfa..5c3c339b 100644 --- a/tests/inc_sub +++ b/tests/inc_sub @@ -1,6 +1,6 @@ #!/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/md5.t b/tests/md5.t index edfe4889..d8912133 100644 --- a/tests/md5.t +++ b/tests/md5.t @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module1 b/tests/module1 index 69ad4610..a219d750 100644 --- a/tests/module1 +++ b/tests/module1 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module2 b/tests/module2 index f10f9ee8..a7fe9c8d 100644 --- a/tests/module2 +++ b/tests/module2 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module_ignore b/tests/module_ignore index b1e2b8ba..7db7e636 100644 --- a/tests/module_ignore +++ b/tests/module_ignore @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2006-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module_import b/tests/module_import index 636fd421..3974689a 100644 --- a/tests/module_import +++ b/tests/module_import @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module_relative b/tests/module_relative index 05c2303c..492feffc 100644 --- a/tests/module_relative +++ b/tests/module_relative @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/module_statements b/tests/module_statements index 113930b5..b9524e44 100644 --- a/tests/module_statements +++ b/tests/module_statements @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/moo_cond b/tests/moo_cond index e03d71f2..67f72721 100644 --- a/tests/moo_cond +++ b/tests/moo_cond @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/moose_basic b/tests/moose_basic index 55d75524..3517111f 100644 --- a/tests/moose_basic +++ b/tests/moose_basic @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/moose_cond b/tests/moose_cond index b404537e..1f75e1de 100644 --- a/tests/moose_cond +++ b/tests/moose_cond @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/moose_constraint b/tests/moose_constraint index d95ef353..83fdcddf 100644 --- a/tests/moose_constraint +++ b/tests/moose_constraint @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/overload_bool b/tests/overload_bool index cb224776..fb0d08ac 100644 --- a/tests/overload_bool +++ b/tests/overload_bool @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2006-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/overload_bool2 b/tests/overload_bool2 index 074b36ee..89d5fc51 100644 --- a/tests/overload_bool2 +++ b/tests/overload_bool2 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2014-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2014-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/overloaded b/tests/overloaded index ddce75e4..85d6c390 100644 --- a/tests/overloaded +++ b/tests/overloaded @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2003-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2003-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/padrange b/tests/padrange index fa99729f..59e950eb 100644 --- a/tests/padrange +++ b/tests/padrange @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/pod b/tests/pod index 54aacc35..b3ffab6e 100644 --- a/tests/pod +++ b/tests/pod @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/pod_nocp b/tests/pod_nocp index b0f1e72a..72a1eff0 100644 --- a/tests/pod_nocp +++ b/tests/pod_nocp @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/readonly b/tests/readonly index 8f0d8f01..fe0232a0 100644 --- a/tests/readonly +++ b/tests/readonly @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2012-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2012-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/recursive_sub b/tests/recursive_sub index dda45d60..4782521b 100644 --- a/tests/recursive_sub +++ b/tests/recursive_sub @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2022-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2022-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/require b/tests/require index 43413471..ac0e063a 100644 --- a/tests/require +++ b/tests/require @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/signature b/tests/signature index 3ce936e1..76792de9 100644 --- a/tests/signature +++ b/tests/signature @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2019-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2019-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/skip b/tests/skip index 0c2de7e8..f2862de1 100644 --- a/tests/skip +++ b/tests/skip @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/special_blocks b/tests/special_blocks index 6f4a2fe4..4b503680 100644 --- a/tests/special_blocks +++ b/tests/special_blocks @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/statement b/tests/statement index fa84a1c2..0e2b96e6 100644 --- a/tests/statement +++ b/tests/statement @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/subs_only b/tests/subs_only index 870b785e..943d2339 100644 --- a/tests/subs_only +++ b/tests/subs_only @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2006-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2006-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/t0 b/tests/t0 index 9b32203d..9b7cd101 100644 --- a/tests/t0 +++ b/tests/t0 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/t1 b/tests/t1 index 1cb833f0..7b2d5053 100644 --- a/tests/t1 +++ b/tests/t1 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/t2 b/tests/t2 index 91366c72..b5c57f3d 100644 --- a/tests/t2 +++ b/tests/t2 @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/taint b/tests/taint index 416c8c43..539b23fa 100644 --- a/tests/taint +++ b/tests/taint @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2013-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/trivial b/tests/trivial index 9d2f73b1..43076774 100644 --- a/tests/trivial +++ b/tests/trivial @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/uncoverable b/tests/uncoverable index 04002459..216c7447 100644 --- a/tests/uncoverable +++ b/tests/uncoverable @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/uncoverable_error b/tests/uncoverable_error index db536ed6..93a0b2b3 100644 --- a/tests/uncoverable_error +++ b/tests/uncoverable_error @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2023, Paul Johnson (paul@pjcj.net) +# Copyright 2023-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/uncoverable_error_ignore b/tests/uncoverable_error_ignore index 3ade4508..46901438 100644 --- a/tests/uncoverable_error_ignore +++ b/tests/uncoverable_error_ignore @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2023, Paul Johnson (paul@pjcj.net) +# Copyright 2023-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/v-58x b/tests/v-58x index e762261f..89925f82 100644 --- a/tests/v-58x +++ b/tests/v-58x @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/tests/xor_constant_fold b/tests/xor_constant_fold index 41c4179b..2985c578 100644 --- a/tests/xor_constant_fold +++ b/tests/xor_constant_fold @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/utils/Devel/Cover/BuildUtils.pm b/utils/Devel/Cover/BuildUtils.pm index 909eb8e6..02370a7a 100644 --- a/utils/Devel/Cover/BuildUtils.pm +++ b/utils/Devel/Cover/BuildUtils.pm @@ -1,4 +1,4 @@ -# Copyright 2010-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2010-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -18,44 +18,44 @@ our @ISA = "Exporter"; our @EXPORT_OK = qw(find_prove cpus nice_cpus njobs prove_command); sub find_prove { - my $perl = $^X; - unless (-x $perl) { - my ($dir) = grep -x "$_/$perl", split /:/, $ENV{PATH}; - $perl = "$dir/$perl"; - } + my $perl = $^X; + unless (-x $perl) { + my ($dir) = grep -x "$_/$perl", split /:/, $ENV{PATH}; + $perl = "$dir/$perl"; + } - eval { $perl = readlink($perl) || $perl }; - # print "perl is [$perl]\n"; - my ($dir) = $perl =~ m|(.*)/[^/]+|; - my ($prove) = grep -x, <$dir/prove*>; + eval { $perl = readlink($perl) || $perl }; + # print "perl is [$perl]\n"; + my ($dir) = $perl =~ m|(.*)/[^/]+|; + my ($prove) = grep -x, <$dir/prove*>; - print "prove is in $dir\n"; + print "prove is in $dir\n"; - $prove + $prove } sub cpus { - my $cpus = 1; - eval { chomp ($cpus = `grep -c processor /proc/cpuinfo 2>/dev/null`) }; - $cpus || eval { ($cpus) = `sysctl hw.ncpu` =~ /(\d+)/ }; - $cpus || 1 + my $cpus = 1; + eval { chomp($cpus = `grep -c processor /proc/cpuinfo 2>/dev/null`) }; + $cpus || eval { ($cpus) = `sysctl hw.ncpu` =~ /(\d+)/ }; + $cpus || 1 } sub nice_cpus { - $ENV{DEVEL_COVER_CPUS} || do { - my $cpus = cpus; - $cpus-- if $cpus > 3; - $cpus-- if $cpus > 6; - $cpus - } + $ENV{DEVEL_COVER_CPUS} || do { + my $cpus = cpus; + $cpus-- if $cpus > 3; + $cpus-- if $cpus > 6; + $cpus + } } sub njobs { nice_cpus } sub prove_command { - my $prove = find_prove or return; - my $cpus = nice_cpus; - "$prove -brj$cpus t" + my $prove = find_prove or return; + my $cpus = nice_cpus; + "$prove -brj$cpus t" } __END__ @@ -84,7 +84,7 @@ Huh? =head1 LICENCE -Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +Copyright 2001-2024, Paul Johnson (paul@pjcj.net) This software is free. It is licensed under the same terms as Perl itself. diff --git a/utils/all_versions b/utils/all_versions index 40ca2e78..7b0a9178 100755 --- a/utils/all_versions +++ b/utils/all_versions @@ -1,6 +1,6 @@ #!/usr/bin/env perl -# Copyright 2004-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2004-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -18,175 +18,181 @@ use Parallel::Iterator "iterate_as_array"; use Devel::Cover::BuildUtils qw( prove_command njobs ); my $Options = { - build => 0, - dry_run => 0, - force => 0, - ignore_failure => 0, - silent => 1, - version => [], + build => 0, + dry_run => 0, + force => 0, + ignore_failure => 0, + silent => 1, + version => [], }; my $Silent = " >/dev/null 2>&1"; sub get_options { - die "Bad option" unless - GetOptions($Options, qw( - build! - dry_run! - force! - ignore_failure! - list! - silent! - version=s - )); - - $Options->{version} = [ map { ($_, "$_-thr") } qw( - 5.12.0 5.12.1 5.12.2 5.12.3 5.12.4 5.12.5 - 5.14.0 5.14.1 5.14.2 5.14.3 5.14.4 - 5.16.0 5.16.1 5.16.2 5.16.3 - 5.18.0 5.18.1 5.18.2 5.18.3 5.18.4 - 5.20.0 5.20.1 5.20.2 5.20.3 - 5.22.0 5.22.1 5.22.2 5.22.3 5.22.4 - 5.24.0 5.24.1 5.24.2 5.24.3 5.24.4 - 5.26.0 5.26.1 5.26.2 5.26.3 - 5.28.0 5.28.1 5.28.2 - 5.30.0 5.30.1 5.30.2 - 5.32.0 5.32.1 - 5.34.0 5.34.1 - 5.36.0 5.36.1 - 5.38.0 - 5.39.1 5.39.2 5.39.3 5.39.4 - ) ] unless @{$Options->{version}}; - $Options->{version} = - [ grep { - my $cmd = "dc-$_ -v$Silent"; - my $exists = eval { !system $cmd }; - $Options->{force} || ($exists ^ $Options->{build}) - } @{$Options->{version}} ]; - print "Versions: @{$Options->{version}}\n"; - if ($Options->{list}) { - exit; - } + die "Bad option" unless GetOptions( + $Options, qw( + build! + dry_run! + force! + ignore_failure! + list! + silent! + version=s + ) + ); + + $Options->{version} = [ + map { ($_, "$_-thr") } + qw( + 5.12.0 5.12.1 5.12.2 5.12.3 5.12.4 5.12.5 + 5.14.0 5.14.1 5.14.2 5.14.3 5.14.4 + 5.16.0 5.16.1 5.16.2 5.16.3 + 5.18.0 5.18.1 5.18.2 5.18.3 5.18.4 + 5.20.0 5.20.1 5.20.2 5.20.3 + 5.22.0 5.22.1 5.22.2 5.22.3 5.22.4 + 5.24.0 5.24.1 5.24.2 5.24.3 5.24.4 + 5.26.0 5.26.1 5.26.2 5.26.3 + 5.28.0 5.28.1 5.28.2 + 5.30.0 5.30.1 5.30.2 + 5.32.0 5.32.1 + 5.34.0 5.34.1 + 5.36.0 5.36.1 + 5.38.0 5.38.1 5.38.2 + 5.39.1 5.39.2 5.39.3 5.39.4 5.39.5 5.39.6 5.39.7 5.39.8 5.39.9 + ) + ] + unless @{ $Options->{version} }; + $Options->{version} = [ + grep { + my $cmd = "dc-$_ -v$Silent"; + my $exists = eval { !system $cmd }; + $Options->{force} || ($exists ^ $Options->{build}) + } @{ $Options->{version} } + ]; + print "Versions: @{$Options->{version}}\n"; + if ($Options->{list}) { + exit; + } } sub sys { - my ($command, $user) = @_; - print "$command\n"; - return if $Options->{dry_run}; - $command .= $Silent if $Options->{silent} && !$user; - my $ret = system $command; - warn "command failed: $? - $command" if $ret && !$Options->{ignore_failure}; - !$ret + my ($command, $user) = @_; + print "$command\n"; + return if $Options->{dry_run}; + $command .= $Silent if $Options->{silent} && !$user; + my $ret = system $command; + warn "command failed: $? - $command" if $ret && !$Options->{ignore_failure}; + !$ret } sub _mods { - my ($v, $n) = @_; + my ($v, $n) = @_; - my ($s) = $n =~ /(\d+)$/; - my $version = version->parse($n); + my ($s) = $n =~ /(\d+)$/; + my $version = version->parse($n); - my @mods = qw( Test::Harness Test::Warn HTML::Entities ); + my @mods = qw( Test::Harness Test::Warn HTML::Entities ); - return @mods if $v =~ /-thr/ && $s != 1; + return @mods if $v =~ /-thr/ && $s != 1; - push @mods, qw( - Template - Pod::Coverage - Test::Differences - Readonly - Parallel::Iterator - Sereal - JSON::MaybeXS - ); + push @mods, qw( + Template + Pod::Coverage + Test::Differences + Readonly + Parallel::Iterator + Sereal + JSON::MaybeXS + ); - push @mods, "Perl::Tidy" if !$s || $s % 2; - push @mods, "PPI::HTML" if !$s || !($s % 2); + push @mods, "Perl::Tidy" if !$s || $s % 2; + push @mods, "PPI::HTML" if !$s || !($s % 2); - @mods + @mods } sub _build_version { - my ($v) = @_; + my ($v) = @_; - print "building $v\n"; - # sleep 1; return; + print "building $v\n"; + # sleep 1; return; - my ($n) = $v =~ /(\d+\.\d+\.\d+)/ or die "Can't parse [$v}"; + my ($n) = $v =~ /(\d+\.\d+\.\d+)/ or die "Can't parse [$v}"; - my $dir = "$ENV{HOME}/.plenv/versions/dc-$v/bin"; + my $dir = "$ENV{HOME}/.plenv/versions/dc-$v/bin"; + unless (-d $dir) { + my $opts = "-D usedevel"; + $opts .= " -D usethreads" if $v =~ /thr/; + my $j = njobs; + sys "plenv install $n --as dc-$v -j $j $opts --noman" or do { + warn "plenv $v failed"; + return; + }; unless (-d $dir) { - my $opts = "-D usedevel"; - $opts .= " -D usethreads" if $v =~ /thr/; - my $j = njobs; - sys "plenv install $n --as dc-$v -j $j $opts --noman" or do { - warn "plenv $v failed"; - return; - }; - unless (-d $dir) { - warn "perl for $v does not exist"; - return; - } + warn "perl for $v does not exist"; + return; } - - $ENV{PATH} = "$dir:$ENV{PATH}"; - sys "curl -L http://cpanmin.us | perl - App::cpanminus" or do { - warn "cpanm installation for $v failed"; - return; - }; - - my @mods = _mods($v, $n); - sys "cpanm --notest @mods" or do { - warn "module installation for $v failed"; - return; - }; - - my $ln = "/usr/local/bin/dc-$v"; - sys "sudo rm -f $ln$Silent"; - - my ($perl) = "$dir/perl"; - print "$perl => $ln\n"; - sys "sudo ln -s $perl $ln" or warn "Can't ln $perl => $ln: $!"; + } + + $ENV{PATH} = "$dir:$ENV{PATH}"; + sys "curl -L http://cpanmin.us | perl - App::cpanminus" or do { + warn "cpanm installation for $v failed"; + return; + }; + + my @mods = _mods($v, $n); + sys "cpanm --notest @mods" or do { + warn "module installation for $v failed"; + return; + }; + + my $ln = "/usr/local/bin/dc-$v"; + sys "sudo rm -f $ln$Silent"; + + my ($perl) = "$dir/perl"; + print "$perl => $ln\n"; + sys "sudo ln -s $perl $ln" or warn "Can't ln $perl => $ln: $!"; } sub _build_versions { - my ($v) = @_; - _build_version $v; - _build_version "$v-thr"; + my ($v) = @_; + _build_version $v; + _build_version "$v-thr"; } sub build { - print "Building: @{$Options->{version}}\n"; - my @res = iterate_as_array( - { workers => njobs }, - sub { - my (undef, $v) = @_; - _build_versions($v); - }, - [ grep !/-thr/, @{$Options->{version}} ] - ); - exit; + print "Building: @{$Options->{version}}\n"; + my @res = iterate_as_array( + { workers => njobs }, + sub { + my (undef, $v) = @_; + _build_versions($v); + }, + [ grep !/-thr/, @{ $Options->{version} } ] + ); + exit; } sub main { - get_options; - build if $Options->{build}; - - my $command = "@ARGV" or die "Usage: $0 [-v version] command\n"; - - for my $v (@{$Options->{version}}) { - my $perl = "dc-$v"; - (my $c = $command) =~ s/=perl/$perl/g; - # print "Running [$c] from $v\n"; - # $c =~ s/=v/$v/g; - if ($c =~ /^make /) { - sys "rm -rf t/e2e"; - sys "$perl Makefile.PL"; - sys "make clean"; - sys "$perl Makefile.PL"; - sys "make"; - } - sys $c, 1; + get_options; + build if $Options->{build}; + + my $command = "@ARGV" or die "Usage: $0 [-v version] command\n"; + + for my $v (@{ $Options->{version} }) { + my $perl = "dc-$v"; + (my $c = $command) =~ s/=perl/$perl/g; + # print "Running [$c] from $v\n"; + # $c =~ s/=v/$v/g; + if ($c =~ /^make /) { + sys "rm -rf t/e2e"; + sys "$perl Makefile.PL"; + sys "make clean"; + sys "$perl Makefile.PL"; + sys "make"; } + sys $c, 1; + } } main diff --git a/utils/create_all_gold b/utils/create_all_gold index 702bee1a..8bbdfe3c 100755 --- a/utils/create_all_gold +++ b/utils/create_all_gold @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2011-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2011-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. diff --git a/utils/create_gold b/utils/create_gold index e84db9ea..773acce8 100755 --- a/utils/create_gold +++ b/utils/create_gold @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2002-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2002-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -27,30 +27,30 @@ mkdir "test_output" unless -d "test_output"; mkdir "test_output/cover" unless -d "test_output/cover"; unless (@tests) { - opendir D, "tests" or die "Cannot opendir tests: $!"; - for my $t (sort readdir D) { - next unless -f "tests/$t"; - next if $t =~ /\.(pm|pl|uncoverable|version|org|bak|swp)$/; - next if $t =~ /~$/; - push @tests, $t; - } - closedir D or die "Cannot closedir tests: $!"; + opendir D, "tests" or die "Cannot opendir tests: $!"; + for my $t (sort readdir D) { + next unless -f "tests/$t"; + next if $t =~ /\.(pm|pl|uncoverable|version|org|bak|swp)$/; + next if $t =~ /~$/; + push @tests, $t; + } + closedir D or die "Cannot closedir tests: $!"; } for my $test (@tests) { - my $e = "t/e2e"; - my ($file) = grep -e, "$e/$test", "$e/a$test.t"; - $file ||= $test; - print STDERR "creating golden results for $test: "; - # print "requiring [$file]\n"; - die "Can't fork" unless defined(my $pid = fork); - if ($pid) { - waitpid $pid, 0; - } else { - no warnings "redefine"; - local *Devel::Cover::Test::run_test = sub {}; - my $t = require "./$file" or die "Can't require $file: $!"; - $t->create_gold && print STDERR "\n"; - exit; - } + my $e = "t/e2e"; + my ($file) = grep -e, "$e/$test", "$e/a$test.t"; + $file ||= $test; + print STDERR "creating golden results for $test: "; + # print "requiring [$file]\n"; + die "Can't fork" unless defined(my $pid = fork); + if ($pid) { + waitpid $pid, 0; + } else { + no warnings "redefine"; + local *Devel::Cover::Test::run_test = sub { }; + my $t = require "./$file" or die "Can't require $file: $!"; + $t->create_gold && print STDERR "\n"; + exit; + } } diff --git a/utils/dc b/utils/dc index f54916b2..174ba989 100755 --- a/utils/dc +++ b/utils/dc @@ -1,40 +1,53 @@ -#!/bin/bash +#!/usr/bin/env bash -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. # The latest version of this software should be available from my homepage: # http://www.pjcj.net -set -euo pipefail +if ((BASH_VERSINFO[0] < 5)); then + echo "❌ bash version $BASH_VERSION is too old. Please install v5 or higher." + exit 1 +fi + +set -eEuo pipefail +shopt -s inherit_errexit script=$(basename "$0") readl=readlink -if which greadlink >&/dev/null; then readl=greadlink; fi -srcdir=$($readl -f "$(dirname "$0")") +if command -v greadlink >&/dev/null; then readl=greadlink; fi +srcdir=$("$readl" -f "$(dirname "$0")") readonly LOG_FILE="/tmp/$script.log" -_p() { __l=$1; shift; echo "$__l $script: $*" | tee -a "$LOG_FILE" >&2; } -pt() { _p "[TRACE] " "$*"; } -pd() { _p "[DEBUG] " "$*"; } -pi() { _p "[INFO] " "$*"; } -pw() { _p "[WARNING]" "$*"; } -pe() { _p "[ERROR] " "$*"; } -pf() { _p "[FATAL] " "$*"; exit 1; } +_p() { + __l=$1 + shift + echo "$__l $script: $*" | tee -a "$LOG_FILE" >&2 +} +pt() { _p "[TRACE] " "$*"; } +pd() { _p "[DEBUG] " "$*"; } +pi() { _p "[INFO] " "$*"; } +pw() { _p "[WARNING]" "$*"; } +pe() { _p "[ERROR] " "$*"; } +pf() { + _p "[FATAL] " "$*" + exit 1 +} usage() { - cat < /dev/null - # shellcheck disable=SC2181 - if [ $? = 0 ]; then - $docker logs "$name" > "$staging/$name.out" - local_staging="$staging/$name" - mkdir -p "$local_staging" - $docker cp "$name:/root/staging" "$local_staging" - if [ -d "$local_staging" ]; then - sudo chmod -R 755 "$local_staging" - sudo find "$local_staging" -type f -exec chmod 644 {} \; - sudo chown -R pjcj:pjcj "$local_staging" - cd "$local_staging"/* || exit - for f in *; do - if [ -d "$f" ]; then - rm -rf "${staging:?}/$f" - mv "$f" "$staging" - fi - done - rm -r "$local_staging" - fi - fi - $docker rm "$name" > /dev/null - ;; - cpancover-generate-html) - pi "Generating HTML at $(date)" - # perl -V - $0 cpancover-compress-old-versions - $0 cpancover --generate_html - $0 cpancover-compress - json=$results_dir/cpancover.json - tmp=$json-tmp-$$.gz - pi "Compressing $json" - pigz < "$json" > "$tmp" && mv "$tmp" "$json.gz" - pi "Done" - ;; - cpancover-run) - export DEVEL_COVER_CPUS=10 - while true; do - pi "Starting cpancover run at $(date) on $DEVEL_COVER_CPUS cpus" - $0 cpancover-rm-docker # just in case something bad happened - $0 cpancover-latest | $0 cpancover - $0 cpancover-generate-html - pi "Finished cpancover run at $(date)" - sleep 600 # 10 minutes - done - ;; - cpancover-compress-old-versions) - keep="${2:-3}" - $0 cpancover --nobuild --compress_old_versions "$keep" - ;; - cpancover-kill-docker) - $docker ps -a | tail -n +2 | awk '{ print $1 }' \ - | xargs -r "$docker" kill - ;; - cpancover-rm-docker) - $docker ps -a | tail -n +2 | awk '{ print $1 }' \ - | xargs -r "$docker" rm -f - $docker system prune --force - ;; - cpancover-start-queue) - COVER_DEBUG=1 perl bin/queue minion worker -j 4 - ;; - cpancover-start-minion) - COVER_DEBUG=1 perl bin/queue daemon -l http://\*:30000 -m production - ;; - cpancover-add) - module="$2" - COVER_DEBUG=1 perl bin/queue add "$module" - ;; - sereal_each_bug) - perl="${2:-perl}" - $perl Makefile.PL - make - rm -rf cover_db - cp tests/trivial tests/change - $perl -Mblib -MDevel::Cover tests/change - cp tmp/change tests - $perl -Mblib -MDevel::Cover tests/change - $perl -Mblib bin/cover -report text - rm tests/change - ;; - options) - perl -nE 'say $1 =~ s/"//gr =~ s/\s*\|\s*/\n/gr' \ - -E 'if /^ {8}"?([a-zA-Z0-9_ "|\\-]+)"?(?:\)|\s*\|\s*\\)$/' \ - -E '&& $1 !~ /^_/' < "$0" - ;; - *) - pf "Unknown option: $1" - ;; - esac + ((verbose)) && pi "Running $*" + [[ ${1:-} == "" ]] && pf "Missing argument" + case "$1" in + update-copyright) + from="${2:-$(date +'%Y' --date='last year')}" + to="${3:-$(date +'%Y')}" + pi "Updating copyright from $from to $to" + me="Paul Johnson" + files=$(git ls-files) + # shellcheck disable=SC2086 + perl -pi -e "s/Copyright \\d+-\\K$from(, $me)/$to\$1/i" $files + # shellcheck disable=SC2086 + perl -pi -e "s/Copyright $from\\K(, $me)/-$to\$1/i" $files + ;; + install_dependencies) + cpanm --notest App::cpm + if command -v plenv >/dev/null 2>&1; then + plenv rehash + fi + cpm install --workers="$("$0" nice_cpus)" --global \ + Sereal Digest::MD5 Template Pod::Coverage::CountParents \ + Capture::Tiny Parallel::Iterator Template Class::XSAccessor \ + Moo namespace::clean CPAN::Releases::Latest JSON::MaybeXS \ + CPAN::DistnameInfo HTML::Entities + ;; + install_development_dependencies) + cpanm --notest App::cpm + if command -v plenv >/dev/null 2>&1; then + plenv rehash + fi + cpm install --workers="$("$0" nice_cpus)" --global \ + Perl::Critic Perl::Tidy Dist::Zilla + dzil authordeps --missing | + xargs cpm install --workers="$("$0" nice_cpus)" --global + dzil listdeps --missing | + xargs cpm install --workers="$("$0" nice_cpus)" --global + ;; + nice_cpus) + perl -Iutils -MDevel::Cover::BuildUtils=nice_cpus \ + -e "print nice_cpus" + ;; + all_versions) + shift + ./utils/all_versions "$@" + ;; + install_cpancover_perl) + version="${2:?No version specified}" + yes | plenv uninstall cpancover || true + plenv install --as cpancover -j 32 -D usedevel --noman "$version" + PLENV_VERSION=cpancover plenv install-cpanm + PLENV_VERSION=cpancover dc install_dependencies + ;; + install_dc_perl) + version="${2:?No version specified}" + yes | plenv uninstall dc || true + plenv install --as dc -j 32 -D usedevel --noman "$version" + PLENV_VERSION=dc plenv install-cpanm + PLENV_VERSION=dc dc install_dependencies + PLENV_VERSION=dc dc install_development_dependencies + ;; + cpancover) + shift + jobs=$("$0" nice_cpus) + mkdir -p "$results_dir" + if ((alocal)); then + root= + [[ -d /dc ]] && root=/dc/ + cpancover="perl -Mblib=$root ${root}bin/cpancover --local" + else + cpancover=cpancover + fi + ((verbose)) && cpancover="$cpancover --verbose" + ((force)) && cpancover="$cpancover --force" + ((dryrun)) && cpancover="$cpancover --dryrun" + cmd="$cpancover --results_dir $results_dir --workers $jobs $*" + ((verbose)) && pi "$cmd" + $cmd + ;; + cpancover-compress) + find "$results_dir/" -name __failed__ -prune -o \ + -type f -not -name '*.gz' -not -name '*.json' \ + -exec gzip -f9 {} \; + ;; + cpancover-uncompress-dir) + subdir="${2:?No subdir specified}" + find "$results_dir/$subdir/" -name __failed__ -prune -o \ + -type f -name '*.gz' \ + -exec gzip -d {} \; + ;; + cpancover-latest) + "$0" cpancover --latest + ;; + cpancover-build-module) + module="$2" + "$0" cpancover --local_build --docker "$docker" --workers 1 "$module" + "$0" cpancover-compress + ;; + cpancover-docker-shell) + staging="${2:-$results_dir}" + mkdir -p "$staging" + # pd $name + "$docker" run -it \ + --volume="$dcdir:/dc:ro" \ + --volume="$staging:/remote_staging:rw" \ + --workdir=/dc --rm=false \ + --memory=1g \ + "$docker_image" /bin/bash + ;; + cpancover-docker-module) + module="$2" + name="$3" + staging="${4:-$results_dir}" + mkdir -p "$staging" + # pd "name: $name" + l="" + ((alocal)) && l="--local" + dir="" + ((alocal)) && [[ -d /dc ]] && dir=/dc/ + # ((verbose)) && pi "[-$l-] [$dir] [$module]" + # set -x + container=$("$docker" run -d \ + --volume="$dcdir:/dc:ro" \ + --volume="$staging:/remote_staging:ro" \ + --workdir=/dc --rm=false --name="$name" \ + --memory=1g \ + "$docker_image" \ + "${dir}dc" "$l" cpancover-build-module "$module") + # https://github.com/dotcloud/docker/issues/3986 + ((verbose)) && pi "container is $container" + "$docker" wait "$name" >/dev/null + # shellcheck disable=SC2181 + if [[ $? == 0 ]]; then + "$docker" logs "$name" >"$staging/$name.out" + local_staging="$staging/$name" + mkdir -p "$local_staging" + "$docker" cp "$name:/root/staging" "$local_staging" + if [[ -d $local_staging ]]; then + sudo chmod -R 755 "$local_staging" + sudo find "$local_staging" -type f -exec chmod 644 {} \; + sudo chown -R pjcj:pjcj "$local_staging" + cd "$local_staging"/* || exit + for f in *; do + if [[ -d $f ]]; then + rm -rf "${staging:?}/$f" + mv "$f" "$staging" + fi + done + rm -r "$local_staging" + fi + fi + "$docker" rm "$name" >/dev/null + ;; + cpancover-generate-html) + pi "Generating HTML at $(date)" + # perl -V + "$0" cpancover-compress-old-versions + "$0" cpancover --generate_html + "$0" cpancover-compress + json=$results_dir/cpancover.json + tmp=$json-tmp-$$.gz + pi "Compressing $json" + pigz <"$json" >"$tmp" && mv "$tmp" "$json.gz" + pi "Done" + ;; + cpancover-run) + export DEVEL_COVER_CPUS=10 + while true; do + pi "Starting cpancover run at $(date) on $DEVEL_COVER_CPUS cpus" + "$0" cpancover-rm-docker # just in case something bad happened + "$0" cpancover-latest | "$0" cpancover + "$0" cpancover-generate-html + pi "Finished cpancover run at $(date)" + sleep 600 # 10 minutes + done + ;; + cpancover-compress-old-versions) + keep="${2:-3}" + "$0" cpancover --nobuild --compress_old_versions "$keep" + ;; + cpancover-kill-docker) + "$docker" ps -a | tail -n +2 | awk '{ print $1 }' | + xargs -r "$docker" kill + ;; + cpancover-rm-docker) + "$docker" ps -a | tail -n +2 | awk '{ print $1 }' | + xargs -r "$docker" rm -f + "$docker" system prune --force + ;; + cpancover-start-queue) + COVER_DEBUG=1 perl bin/queue minion worker -j 4 + ;; + cpancover-start-minion) + COVER_DEBUG=1 perl bin/queue daemon -l http://\*:30000 -m production + ;; + cpancover-add) + module="$2" + COVER_DEBUG=1 perl bin/queue add "$module" + ;; + sereal_each_bug) + perl="${2:-perl}" + "$perl" Makefile.PL + make + rm -rf cover_db + cp tests/trivial tests/change + "$perl" -Mblib -MDevel::Cover tests/change + cp tmp/change tests + "$perl" -Mblib -MDevel::Cover tests/change + "$perl" -Mblib bin/cover -report text + rm tests/change + ;; + options) + perl -nE 'say $1 =~ s/"//gr =~ s/\s*\|\s*/\n/gr' \ + -E 'if /^ {2}"?([a-zA-Z0-9_ "|\\-]+)"?(?:\)|\s*\|\s*\\)$/' \ + -E '&& $1 !~ /^_/' <"$0" + ;; + *) + pf "Unknown option: $1" + ;; + esac } -if [[ "${BASH_SOURCE[0]}" = "$0" ]]; then - trap cleanup EXIT INT - main "$@" +if [[ ${BASH_SOURCE[0]} == "$0" ]]; then + trap cleanup EXIT INT + main "$@" fi diff --git a/utils/mail_contributors b/utils/mail_contributors index 9249acb8..5facb43d 100755 --- a/utils/mail_contributors +++ b/utils/mail_contributors @@ -1,6 +1,6 @@ #!/usr/bin/env perl -# Copyright 2013-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2013-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -17,15 +17,15 @@ use warnings; use Email::Stuffer; sub main { - while (<>) { - chomp; - next unless /\@/; - # say; - sleep 10; - my @parts = split / /; - my $email = $parts[-1]; - my $line = $_; - my $body = <<"EOM"; + while (<>) { + chomp; + next unless /\@/; + # say; + sleep 10; + my @parts = split / /; + my $email = $parts[-1]; + my $line = $_; + my $body = <<"EOM"; Hello, I'm contacting you because you are one of the Authors of Devel::Cover. @@ -59,19 +59,16 @@ Paul -- Paul Johnson - paul\@pjcj.net EOM - eval { - Email::Stuffer->from ('Paul Johnson ') - ->to ($email) - ->subject ("Devel::Cover Authors File") - ->text_body($body) - ->send_or_die; - }; - if ($@) { - say "Failed to send mail <$line>\n$@" - } else { - say "Sent mail <$line>" - } + eval { + Email::Stuffer->from('Paul Johnson ')->to($email) + ->subject("Devel::Cover Authors File")->text_body($body)->send_or_die; + }; + if ($@) { + say "Failed to send mail <$line>\n$@" + } else { + say "Sent mail <$line>" } + } } main diff --git a/utils/makeh b/utils/makeh index f4b00834..27fdac56 100755 --- a/utils/makeh +++ b/utils/makeh @@ -1,6 +1,6 @@ #!/usr/bin/perl -# Copyright 2001-2023, Paul Johnson (paul@pjcj.net) +# Copyright 2001-2024, Paul Johnson (paul@pjcj.net) # This software is free. It is licensed under the same terms as Perl itself. @@ -11,23 +11,25 @@ use strict; use warnings; my $Command = { - strip_criterion => sub { - my ($command, $criterion, $file) = @_; - my $t; - local ($^I, @ARGV) = (".bak", $file); - while (<>) { - $t = index($_, "$criterion code") -3 if !defined $t || $t < 0; - substr $_, $t, 7, "" - if /^line err stmt/ .. /^--------/ and $t > -1 and length > $t; - print; - } - }, + strip_criterion => sub { + my ($command, $criterion, $file) = @_; + my $t; + local ($^I, @ARGV) = (".bak", $file); + while (<>) { + $t = index($_, "$criterion code") - 3 if !defined $t || $t < 0; + substr $_, $t, 7, "" + if /^line err stmt/ .. /^--------/ + and $t > -1 + and length > $t; + print; + } + } }; sub main { - my ($command) = @ARGV; - die "No such command: $command" unless $Command->{$command}; - $Command->{$command}->(@ARGV) + my ($command) = @ARGV; + die "No such command: $command" unless $Command->{$command}; + $Command->{$command}->(@ARGV) } main diff --git a/utils/queue.conf b/utils/queue.conf index 7c96c4f8..9b23e3b9 100644 --- a/utils/queue.conf +++ b/utils/queue.conf @@ -1,3 +1 @@ -{ - results_dir => "/cover/staging_dev", -} +{ results_dir => "/cover/staging_dev" } diff --git a/utils/scanuncov b/utils/scanuncov index 4c510ed6..ff1a82f9 100755 --- a/utils/scanuncov +++ b/utils/scanuncov @@ -5,15 +5,15 @@ use Digest::MD5; process_file($_) for @ARGV; sub process_file { - my $file = shift; - open my $fh, $file or die $!; - while (<$fh>) { - my ($count, $crit, $reason) = m/# uncoverable:\s+(\d+)\s+(\w+)\s+(.*$)/ - or next; - my $md5 = Digest::MD5->new->add($_)->hexdigest; - $crit =~ s/s$//; - for (0..$count-1) { - print "$file $crit $md5 $_ 0 $reason\n"; - } + my $file = shift; + open my $fh, $file or die $!; + while (<$fh>) { + my ($count, $crit, $reason) = m/# uncoverable:\s+(\d+)\s+(\w+)\s+(.*$)/ + or next; + my $md5 = Digest::MD5->new->add($_)->hexdigest; + $crit =~ s/s$//; + for (0 .. $count - 1) { + print "$file $crit $md5 $_ 0 $reason\n"; } + } }