view release on metacpan or  search on metacpan

t/immutable/inline_close_over.t  view on Meta::CPAN

use strict;
use warnings;
use Test::Needs {
  'Data::Visitor' => '0.26',
  'PadWalker'     => undef,
};

use Test::More;

use Class::Load 'load_class';
use Try::Tiny;

my $can_partialdump = try {
    load_class('Devel::PartialDump', { -version => 0.14 }); 1;
};

{
    package Test::Visitor;
    use Moose;
    use Moose::Util::TypeConstraints;
    extends 'Data::Visitor';

    has closed_over => (
        traits  => ['Array'],
        isa     => 'ArrayRef',
        default => sub { [] },
        handles => {
            add_closed_over => 'push',
            closed_over     => 'elements',
            pass            => 'is_empty',
        },
    );

    before visit_code => sub {
        my $self = shift;
        my ($code) = @_;
        my $closed_over = PadWalker::closed_over($code);
        $self->visit_ref($closed_over);
    };

    after visit => sub {
        my $self = shift;
        my ($thing) = @_;

        $self->add_closed_over($thing)
            unless $self->_is_okay_to_close_over($thing);
    };

    sub _is_okay_to_close_over {
        my $self = shift;
        my ($thing) = @_;

        match_on_type $thing => (
            'RegexpRef'  => sub { 1 },
            'Object'     => sub { 0 },
            'GlobRef'    => sub { 0 },
            'FileHandle' => sub { 0 },
            'Any'        => sub { 1 },
        );
    }
}

sub close_over_ok {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($package, $method) = @_;
    my $visitor = Test::Visitor->new;
    my $code = $package->meta->find_method_by_name($method)->body;
    $visitor->visit($code);
    if ($visitor->pass) {
        pass("${package}::${method} didn't close over anything complicated");
    }
    else {
        fail("${package}::${method} closed over some stuff:");
        my @closed_over = $visitor->closed_over;
        for my $i (1..10) {
            last unless @closed_over;
            my $closed_over = shift @closed_over;
            if ($can_partialdump) {
                $closed_over = Devel::PartialDump->new->dump($closed_over);
            }
            diag($closed_over);
        }
        diag("... and " . scalar(@closed_over) . " more")
            if @closed_over;
    }
}

{
    package Foo;
    use Moose;
    use Moose::Util::TypeConstraints;

    has foo => (
        is  => 'ro',
        isa => 'Str',
    );