File Coverage

blib/lib/Test2/Tools/DOM/Check.pm

Criterion	Covered	Total	%
statement	71	71	100.0
branch	32	32	100.0
condition	7	10	70.0
subroutine	13	13	100.0
pod	3	6	50.0
total	126	132	95.4

package Test2::Tools::DOM::Check;

use v5.20;
use warnings;
use experimental 'signatures';

use Test2::Util ();
use Mojo::DOM58;

our $VERSION = '0.100';

use parent 'Test2::Compare::Base';

sub name { '' }

sub verify ( $self, %params ) { !!$params{exists} }

sub init ( $self ) { $self->{calls} = [] }

sub add_call ( $self, $call, $check, $name, $context, @ ) {
    $name
        ||= ref $call eq 'ARRAY' ? $call->[0]
          : ref $call eq 'CODE'  ? '\&CODE'
          : $call;

    push @{ $self->{calls} } => [ $call, $check, $name, $context || 'scalar' ];
}

sub deltas ( $self, %params ) {
    my @deltas;
    my ( $got, $convert, $seen ) = @params{qw( got convert seen )};

    $self->{dom} = ref $got eq 'Mojo::DOM58' ? $got : Mojo::DOM58->new($got);

    if ( $self->{dom}->type eq 'root' ) {
        # Keep root in scope.
        # See https://github.com/mojolicious/mojo/issues/1924
        $self->{root} = $self->{dom};

        # For usability's sake, if we received the root of the DOM, we move
        # to its first child (if one exists). In the contexts where this
        # module will be used, this will in most cases be what people expect.
        if ( my $top = $self->{dom}->children->first ) {
            $self->{dom} = $top;
        }
    }

    my $dom = $self->{dom};

    for (@{ $self->{calls} // [] }) {
        my ( $method, $check, $name, $context ) = @$_;

        my @args;
        ( $method, @args ) = @$method if ref $method eq 'ARRAY';

        $check = $convert->($check);

        $method = ref $method eq 'CODE'
            ? $method
            : $dom->can($name);

        Carp::croak "Cannot call '$name' on an object of type " . ref $dom
            unless $method;


        my $value;
        my ( $ok, $err ) = Test2::Util::try {
            $value = $context eq 'list' ? [ $dom->$method(@args) ] :
                     $context eq 'hash' ? { $dom->$method(@args) } :
                                            $dom->$method(@args);
        };

        if ($ok) {
            my %args = (
                id      => [ METHOD => $name ],
                seen    => $seen,
                convert => $convert,
                got     => $value,
                exists  => defined $method,
            );

            # Support HTML/XML logic for element attributes
            if ( @args && $name eq 'attr' ) {
                my $exists = exists $dom->attr->{ $args[0] };
                $args{got}    = $exists if $check->name =~ /^(?:TRUE|FALSE)$/;
                $args{exists} = $exists if $check->name =~ /EXIST/;
            }
            # If the element is not found, it does not exist
            elsif ( $name eq 'at' ) {
                $args{exists} = defined $value if $check->name =~ /EXIST/;
            }

            push @deltas => $check->run(%args);
        }
        else {
            push @deltas => $check->delta_class->new(
                id        => [ METHOD => $name ],
                check     => $check,
                exception => $err,
                got       => undef,
                verified  => undef,
            );
        }
    }

    return @deltas;
}

sub stringify_got { 1 }

1;