File Coverage

blib/lib/Sub/Meta/Returns.pm

Criterion	Covered	Total	%
statement	138	138	100.0
branch	104	104	100.0
condition	49	49	100.0
subroutine	29	29	100.0
pod	20	20	100.0
total	340	340	100.0

package Sub::Meta::Returns;
use 5.010;
use strict;
use warnings;

our $VERSION = "0.15";

use Scalar::Util ();

use overload
    fallback => 1,
    eq => \&is_same_interface
    ;

sub new {
    my ($class, @args) = @_;
    my $v = $args[0];
    my %args = @args == 1 ? ref $v && ref $v eq 'HASH' ? %{$v}
                       : ( scalar => $v, list => $v, void => $v )
             : @args;

    return bless \%args => $class;
}

sub scalar() :method { my $self = shift; return $self->{scalar} } ## no critic (ProhibitBuiltinHomonyms)
sub list()           { my $self = shift; return $self->{list} }
sub void()           { my $self = shift; return $self->{void} }
sub coerce()         { my $self = shift; return $self->{coerce} }

sub has_scalar() { my $self = shift; return defined $self->{scalar} }
sub has_list()   { my $self = shift; return defined $self->{list} }
sub has_void()   { my $self = shift; return defined $self->{void} }
sub has_coerce() { my $self = shift; return defined $self->{coerce} }

sub set_scalar { my ($self, $v) = @_; $self->{scalar} = $v; return $self }
sub set_list   { my ($self, $v) = @_; $self->{list}   = $v; return $self }
sub set_void   { my ($self, $v) = @_; $self->{void}   = $v; return $self }
sub set_coerce { my ($self, $v) = @_; $self->{coerce} = $v; return $self }

sub is_same_interface {
    my ($self, $other) = @_;

    return unless Scalar::Util::blessed($other) && $other->isa('Sub::Meta::Returns');

    if ($self->has_scalar) {
        return unless _eq($self->scalar, $other->scalar)
    }
    else {
        return if $other->has_scalar
    }

    if ($self->has_list) {
        return unless _eq($self->list, $other->list)
    }
    else {
        return if $other->has_list
    }

    if ($self->has_void) {
        return unless _eq($self->void, $other->void)
    }
    else {
        return if $other->has_void
    }

    return !!1;
}

sub is_relaxed_same_interface {
    my ($self, $other) = @_;

    return unless Scalar::Util::blessed($other) && $other->isa('Sub::Meta::Returns');

    if ($self->has_scalar) {
        return unless _eq($self->scalar, $other->scalar)
    }

    if ($self->has_list) {
        return unless _eq($self->list, $other->list)
    }

    if ($self->has_void) {
        return unless _eq($self->void, $other->void)
    }

    return !!1;
}

sub is_same_interface_inlined {
    my ($self, $v) = @_;

    my @src;

    push @src => sprintf("Scalar::Util::blessed(%s) && %s->isa('Sub::Meta::Returns')", $v, $v);

    push @src => $self->has_scalar ? _eq_inlined($self->scalar, sprintf('%s->scalar', $v))
                                   : sprintf('!%s->has_scalar', $v);

    push @src => $self->has_list ? _eq_inlined($self->list, sprintf('%s->list', $v))
                                   : sprintf('!%s->has_list', $v);

    push @src => $self->has_void ? _eq_inlined($self->void, sprintf('%s->void', $v))
                                   : sprintf('!%s->has_void', $v);

    return join "\n && ", @src;
}

sub is_relaxed_same_interface_inlined {
    my ($self, $v) = @_;

    my @src;

    push @src => sprintf("Scalar::Util::blessed(%s) && %s->isa('Sub::Meta::Returns')", $v, $v);

    push @src => _eq_inlined($self->scalar, sprintf('%s->scalar', $v)) if $self->has_scalar;

    push @src => _eq_inlined($self->list, sprintf('%s->list', $v)) if $self->has_list;

    push @src => _eq_inlined($self->void, sprintf('%s->void', $v)) if $self->has_void;

    return join "\n && ", @src;
}

sub _eq {
    my ($type, $other) = @_;

    if (ref $type && ref $type eq "ARRAY") {
        return unless ref $other eq "ARRAY";
        return unless @$type == @$other;
        for (my $i = 0; $i < @$type; $i++) {
            return unless $type->[$i] eq $other->[$i];
        }
    }
    else {
        return unless defined $other && $type eq $other;
    }
    return 1;
}

sub _eq_inlined {
    my ($type, $v) = @_;

    my @src;
    if (ref $type && ref $type eq "ARRAY") {
        push @src => sprintf('ref %s eq "ARRAY"', $v);
        push @src => sprintf('%d == @{%s}', scalar @$type, $v);
        for (my $i = 0; $i < @$type; $i++) {
            push @src => sprintf('"%s" eq %s->[%d]', $type->[$i], $v, $i);
        }
    }
    else {
        push @src => sprintf('defined %s && "%s" eq %s', $v, $type, $v);
    }

    return join "\n && ", @src;
}

sub error_message {
    my ($self, $other) = @_;

    return sprintf('other returns must be Sub::Meta::Returns. got: %s', $other // 'Undef')
        unless Scalar::Util::blessed($other) && $other->isa('Sub::Meta::Returns');

    if ($self->has_scalar) {
        return sprintf('invalid scalar return. got: %s, expected: %s', $other->scalar // '', $self->scalar)
            unless _eq($self->scalar, $other->scalar);
    }
    else {
        return 'should not have scalar return' if $other->has_scalar;
    }

    if ($self->has_list) {
        return sprintf('invalid list return. got: %s, expected: %s', $other->list // '', $self->list)
            unless _eq($self->list, $other->list);
    }
    else {
        return 'should not have list return' if $other->has_list;
    }

    if ($self->has_void) {
        return sprintf('invalid void return. got: %s, expected: %s', $other->void // '', $self->void)
            unless _eq($self->void, $other->void);
    }
    else {
        return 'should not have void return' if $other->has_void;
    }
    return '';
}

sub relaxed_error_message {
    my ($self, $other) = @_;

    return sprintf('other returns must be Sub::Meta::Returns. got: %s', $other // 'Undef')
        unless Scalar::Util::blessed($other) && $other->isa('Sub::Meta::Returns');

    if ($self->has_scalar) {
        return sprintf('invalid scalar return. got: %s, expected: %s', $other->scalar // '', $self->scalar)
            unless _eq($self->scalar, $other->scalar);
    }

    if ($self->has_list) {
        return sprintf('invalid list return. got: %s, expected: %s', $other->list // '', $self->list)
            unless _eq($self->list, $other->list);
    }

    if ($self->has_void) {
        return sprintf('invalid void return. got: %s, expected: %s', $other->void // '', $self->void)
            unless _eq($self->void, $other->void);
    }

    return '';
}

sub _all_eq {
    my $self = shift;
    return $self->has_scalar
       && _eq($self->scalar, $self->list)
       && _eq($self->scalar, $self->void);
}

sub _display {
    my $type = shift;

    if (ref $type && ref $type eq "ARRAY") {
        return sprintf('[%s]', join ",", map { $_ . '' } @$type);
    }
    else {
        return $type . '';
    }
}

sub display {
    my $self = shift;

    if (!$self->has_scalar && !$self->has_list && !$self->has_void) {
        return '*';
    }
    elsif (_all_eq($self)) {
        return _display($self->scalar);
    }
    else {
        my @r;
        for my $key (qw(scalar list void)) {
            my $has = "has_$key";
            push @r => "$key => @{[_display($self->$key)]}" if $self->$has;
        }
        return "(@{[join ', ', @r]})";
    }
}

1;
__END__