File Coverage

blib/lib/Sub/Meta/Param.pm

Criterion	Covered	Total	%
statement	120	120	100.0
branch	68	68	100.0
condition	15	15	100.0
subroutine	33	33	100.0
pod	28	28	100.0
total	264	264	100.0

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

our $VERSION = "0.15";

use Scalar::Util ();

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

my %DEFAULT = ( named => 0, optional => 0, invocant => 0 );

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

    $args{optional} = !delete $args{required} if exists $args{required};
    $args{named}    = !delete $args{positional} if exists $args{positional};
    $args{type}     = delete $args{isa} if exists $args{isa};

    %args = (%DEFAULT, %args);

    return bless \%args => $class;
}

sub name()       { my $self = shift; return $self->{name} // '' }
sub type()       { my $self = shift; return $self->{type} }
sub default()    { my $self = shift; return $self->{default} } ## no critic (ProhibitBuiltinHomonyms)
sub coerce()     { my $self = shift; return $self->{coerce} }
sub optional()   { my $self = shift; return !!$self->{optional} }
sub required()   { my $self = shift; return !$self->{optional} }
sub named()      { my $self = shift; return !!$self->{named} }
sub positional() { my $self = shift; return !$self->{named} }
sub invocant()   { my $self = shift; return !!$self->{invocant} }

sub has_name()    { my $self = shift; return defined $self->{name} }
sub has_type()    { my $self = shift; return defined $self->{type} }
sub has_default() { my $self = shift; return defined $self->{default} }
sub has_coerce()  { my $self = shift; return defined $self->{coerce} }

sub set_name      { my ($self, $v) = @_; $self->{name}     = $v; return $self }
sub set_type      { my ($self, $v) = @_; $self->{type}     = $v; return $self }
sub set_default   { my ($self, $v) = @_; $self->{default}  = $v; return $self }
sub set_coerce    { my ($self, $v) = @_; $self->{coerce}   = $v; return $self }
sub set_optional   { my ($self, $v) = @_; $self->{optional} = !!(defined $v ? $v : 1); return $self }
sub set_required   { my ($self, $v) = @_; $self->{optional} =  !(defined $v ? $v : 1); return $self }
sub set_named      { my ($self, $v) = @_; $self->{named}    = !!(defined $v ? $v : 1); return $self }
sub set_positional { my ($self, $v) = @_; $self->{named}    =  !(defined $v ? $v : 1); return $self }
sub set_invocant   { my ($self, $v) = @_; $self->{invocant} = !!(defined $v ? $v : 1); return $self }

# alias
sub isa_() :method; # NOT isa
*isa_ = \&type;

sub set_isa;
*set_isa = \&set_type;

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

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

    if ($self->has_name) {
        return unless $self->name eq $other->name
    }
    else {
        return if $other->has_name
    }

    if ($self->has_type) {
        return unless $self->type eq ($other->type // '');
    }
    else {
        return if $other->has_type
    }

    return unless $self->optional eq $other->optional;

    return unless $self->named eq $other->named;

    return !!1;
}

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

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

    if ($self->has_name) {
        return unless $self->name eq $other->name
    }

    if ($self->has_type) {
        return unless $self->type eq ($other->type // '');
    }

    return unless $self->optional eq $other->optional;

    return unless $self->named eq $other->named;

    return !!1;
}

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

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

    push @src => $self->has_name ? sprintf("'%s' eq %s->name", $self->name, $v)
                                 : sprintf('!%s->has_name', $v);

    push @src => $self->has_type ? sprintf("'%s' eq (%s->type // '')", "@{[$self->type]}", $v)
                                 : sprintf('!%s->has_type', $v);

    push @src => sprintf("'%s' eq %s->optional", $self->optional, $v);

    push @src => sprintf("'%s' eq %s->named", $self->named, $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::Param')", $v, $v);

    push @src => sprintf("'%s' eq %s->name", $self->name, $v) if $self->has_name;

    push @src => sprintf("'%s' eq (%s->type // '')", "@{[$self->type]}", $v) if $self->has_type;

    push @src => sprintf("'%s' eq %s->optional", $self->optional, $v);

    push @src => sprintf("'%s' eq %s->named", $self->named, $v);

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

sub display {
    my $self = shift;

    my $s = '';
    $s .= $self->type if $self->has_type;
    if ($self->has_name) {
        $s .= sprintf("%s%s%s",
            $self->has_type ? ' ' : '',
            $self->named    ? ':' : '',
            $self->name);
    }
    return $s;
}


1;
__END__