diff --git a/README.md b/README.md index ab91728..1d4537c 100644 --- a/README.md +++ b/README.md @@ -45,6 +45,20 @@ memory_cycle_ok $reference; Checks that `$reference` doesn't have any circular memory references. +## no\_memory\_cycle + +``` +is( + $got, + hash { + no_memory_cycle; + } +); +``` + +Used in the context of a [Test2::Tools::Compare](https://metacpan.org/pod/Test2::Tools::Compare) comparison. The whole test will fail with +appropriate diagnostics if there is a memory cycle in `$got`. + # CAVEATS This module is based on and quite similar to [Test::Memory::Cycle](https://metacpan.org/pod/Test::Memory::Cycle). That module is diff --git a/lib/Test2/Tools/MemoryCycle.pm b/lib/Test2/Tools/MemoryCycle.pm index af44967..9afd8fa 100644 --- a/lib/Test2/Tools/MemoryCycle.pm +++ b/lib/Test2/Tools/MemoryCycle.pm @@ -8,6 +8,7 @@ use experimental qw( signatures ); use Devel::Cycle qw( find_cycle ); use Test2::API qw( context ); use Exporter qw( import ); +use Carp qw( croak ); # ABSTRACT: Check for memory leaks and circular memory references # VERSION @@ -53,19 +54,13 @@ Checks that C<$reference> doesn't have any circular memory references. =cut -our @EXPORT = qw( memory_cycle_ok ); - -# Adapted from Test::Memory::Cycle for Test2::API -sub memory_cycle_ok ($ref, $msg=undef) { - - $msg ||= 'no memory cycle'; +our @EXPORT = qw( memory_cycle_ok no_memory_cycle ); +sub _find_cycle ($ref) { my $cycle_no = 0; my @diags; - # Callback function that is called once for each memory cycle found. - my $callback = sub { - my $path = shift; + my $callback = sub ($path) { $cycle_no++; push( @diags, "Cycle #$cycle_no" ); foreach (@$path) { @@ -85,6 +80,17 @@ sub memory_cycle_ok ($ref, $msg=undef) { }; find_cycle( $ref, $callback ); + + return ($cycle_no, @diags); +} + +# Adapted from Test::Memory::Cycle for Test2::API +sub memory_cycle_ok ($ref, $msg=undef) { + + $msg ||= 'no memory cycle'; + + my($cycle_no, @diags) = _find_cycle($ref); + my $ok = !$cycle_no; my $ctx = context(); @@ -115,6 +121,50 @@ sub _ref_shortname ($ref) { return $refdisp; } +=head2 no_memory_cycle + + is( + $got, + hash { + no_memory_cycle; + } + ); + +Used in the context of a L comparison. The whole test will fail with +appropriate diagnostics if there is a memory cycle in C<$got>. + +=cut + +sub no_memory_cycle () { + my @caller = caller; + + ## only using wantarray to error if called in void or list context + #croak "called in void context, probably a bug in your test." unless defined wantarray; ## no critic (Community::Wantarray) + #croak "called in list context, probably a bug in your test." if wantarray; ## no critic (Community::Wantarray) + + return Test2::Tools::MemoryCycle::NoMemoryCycleCompare->new( + file => $caller[1], + lines => [$caller[2]], + ); + +} + +package Test2::Tools::MemoryCycle::NoMemoryCycleCompare; + +use parent 'Test2::Compare::Base'; + +sub name ($self) { + return 'memory cycle'; +} + +sub verify ($self, %p) { + return $p{exists} ? 1 : 0; +} + +sub deltas ($self, %p) { + ... +} + 1; =head1 CAVEATS diff --git a/t/00_diag.t b/t/00_diag.t index 15de716..a8ce2b8 100644 --- a/t/00_diag.t +++ b/t/00_diag.t @@ -14,6 +14,7 @@ $modules{$_} = $_ for qw( ExtUtils::MakeMaker PadWalker Test2::API + Test2::Compare::Base Test2::V0 );