File Coverage

blib/lib/Sub/Meta.pm

Criterion	Covered	Total	%
statement	289	289	100.0
branch	130	130	100.0
condition	50	50	100.0
subroutine	79	79	100.0
pod	57	57	100.0
total	605	605	100.0

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

our $VERSION = "0.14";

use Carp ();
use Scalar::Util ();
use Sub::Identify ();
use Sub::Util ();
use attributes ();

use Sub::Meta::Parameters;
use Sub::Meta::Returns;

BEGIN {
    # for Pure Perl
    $ENV{PERL_SUB_IDENTIFY_PP} = $ENV{PERL_SUB_META_PP}; ## no critic (RequireLocalizedPunctuationVars)
}

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

sub parameters_class { return 'Sub::Meta::Parameters' }
sub returns_class    { return 'Sub::Meta::Returns' }

sub _croak { require Carp; goto &Carp::croak }

sub new {
    my ($class, @args) = @_;

    my %args = @args == 1 && (ref $args[0]||"") ne "HASH" ? _croak "single arg must be hashref"
             : @args == 1 ? %{$args[0]}
             : @args;

    my $self = bless \%args => $class;

    $self->set_sub(delete $args{sub})             if exists $args{sub}; # build subinfo
    $self->set_subname(delete $args{subname})     if exists $args{subname};
    $self->set_stashname(delete $args{stashname}) if exists $args{stashname};
    $self->set_fullname(delete $args{fullname})   if exists $args{fullname};

    $self->set_is_method($self->_normalize_args_is_method(\%args));
    $self->set_parameters($self->_normalize_args_parameters(\%args));
    $self->set_returns($args{returns});

    # cleaning
    delete $args{args};
    delete $args{slurpy};
    delete $args{invocant};
    delete $args{nshift};

    return $self;
}

sub _normalize_args_is_method {
    my ($self, $args) = @_;

    return !!$args->{invocant}             if exists $args->{invocant};
    return !!$args->{nshift}               if exists $args->{nshift};
    return !!$args->{parameters}{nshift}   if exists $args->{parameters} && exists $args->{parameters}{nshift};
    return !!$args->{parameters}{invocant} if exists $args->{parameters} && exists $args->{parameters}{invocant};
    return !!$args->{is_method}            if exists $args->{is_method};
    return !!0;
}

sub _normalize_args_parameters {
    my ($self, $args) = @_;

    if (exists $args->{parameters}) {
        return $args->{parameters};
    }
    else {
        my $nshift = exists $args->{nshift}    ? $args->{nshift}
                   : $self->is_method          ? 1
                   : 0;

        my $parameters;
        $parameters->{args}     = $args->{args}     if exists $args->{args};
        $parameters->{slurpy}   = $args->{slurpy}   if exists $args->{slurpy};
        $parameters->{invocant} = $args->{invocant} if exists $args->{invocant};
        $parameters->{nshift}   = $nshift;
        return $parameters;
    }
}

sub sub() :method { my $self = shift; return $self->{sub} } ## no critic (ProhibitBuiltinHomonyms)
sub subname()     { my $self = shift; return $self->subinfo->[1] // '' }
sub stashname()   { my $self = shift; return $self->subinfo->[0] // '' }
sub fullname()    {
    my $self = shift;
    my $s = '';
    $s .= $self->stashname . '::' if $self->has_stashname;
    $s .= $self->subname          if $self->has_subname;
    return $s;
}

sub subinfo()     {
    my $self = shift;
    return $self->{subinfo} if $self->{subinfo};
    $self->{subinfo} = $self->_build_subinfo;
    return $self->{subinfo};
}

sub file()        { my $self = shift; return $self->{file}        ||= $self->_build_file }
sub line()        { my $self = shift; return $self->{line}        ||= $self->_build_line }
sub prototype() :method { my $self = shift; return $self->{prototype}   ||= $self->_build_prototype } ## no critic (ProhibitBuiltinHomonyms)
sub attribute()   { my $self = shift; return $self->{attribute}   ||= $self->_build_attribute }
sub is_constant() { my $self = shift; return $self->{is_constant} ||= !!$self->_build_is_constant }
sub is_method()   { my $self = shift; return !!$self->{is_method} }
sub parameters()  { my $self = shift; return $self->{parameters} }
sub returns()     { my $self = shift; return $self->{returns} }

sub args()        { my $self = shift; return $self->parameters->args }
sub all_args()    { my $self = shift; return $self->parameters->all_args }
sub slurpy()      { my $self = shift; return $self->parameters->slurpy }
sub nshift()      { my $self = shift; return $self->parameters->nshift }
sub invocant()    { my $self = shift; return $self->parameters->invocant }
sub invocants()   { my $self = shift; return $self->parameters->invocants }

sub has_sub()        { my $self = shift; return defined $self->{sub} }
sub has_subname()    { my $self = shift; return defined $self->subinfo->[1] }
sub has_stashname()  { my $self = shift; return defined $self->subinfo->[0] }
sub has_prototype()  { my $self = shift; return !!$self->prototype } # after build_prototype
sub has_attribute()  { my $self = shift; return !!$self->attribute } # after build_attribute
sub has_file()       { my $self = shift; return defined $self->{file} }
sub has_line()       { my $self = shift; return defined $self->{line} }

sub set_sub {
    my ($self, $v) = @_;
    $self->{sub} = $v;
    Scalar::Util::weaken($self->{sub});

    # rebuild
    for (qw/subinfo file line prototype attribute is_constant/) {
        delete $self->{$_};
        $self->$_;
    }
    return $self;
}

sub set_subname   { my ($self, $v) = @_; $self->{subinfo}[1]  = $v; return $self }
sub set_stashname { my ($self, $v) = @_; $self->{subinfo}[0]  = $v; return $self }
sub set_fullname  {
    my ($self, $v) = @_;
    $self->set_subinfo($v =~ m!^(.+)::([^:]+)$! ? [$1, $2] : []);
    return $self;
}
sub set_subinfo {
    my ($self, $args) = @_;
    $self->{subinfo} = [ $args->[0], $args->[1] ];
    return $self;
}

sub set_file        { my ($self, $v) = @_; $self->{file}        = $v; return $self }
sub set_line        { my ($self, $v) = @_; $self->{line}        = $v; return $self }
sub set_is_constant { my ($self, $v) = @_; $self->{is_constant} = $v; return $self }
sub set_prototype   { my ($self, $v) = @_; $self->{prototype}   = $v; return $self }
sub set_attribute   { my ($self, $v) = @_; $self->{attribute}   = $v; return $self }
sub set_is_method   { my ($self, $v) = @_; $self->{is_method}   = $v; return $self }

sub set_parameters {
    my ($self, @args) = @_;
    my $v = $args[0];
    if (Scalar::Util::blessed($v)) {
        if ($v->isa('Sub::Meta::Parameters')) {
            $self->{parameters} = $v
        }
        else {
            _croak('object must be Sub::Meta::Parameters');
        }
    }
    else {
        $self->{parameters} = $self->parameters_class->new(@args);
    }
    return $self
}

sub set_args {
    my ($self, $args) = @_;
    $self->parameters->set_args($args);
    return $self;
}

sub set_slurpy {
    my ($self, @args) = @_;
    $self->parameters->set_slurpy(@args);
    return $self;
}

sub set_nshift {
    my ($self, $v) = @_;
    if ($self->is_method && $v == 0) {
        _croak 'nshift of method cannot be zero';
    }
    $self->parameters->set_nshift($v);
    return $self;
}

sub set_invocant {
    my ($self, $v) = @_;
    $self->parameters->set_invocant($v);
    return $self;
}

sub set_returns {
    my ($self, @args) = @_;
    my $v = $args[0];
    if (Scalar::Util::blessed($v) && $v->isa('Sub::Meta::Returns')) {
        $self->{returns} = $v
    }
    else {
        $self->{returns} = $self->returns_class->new(@args);
    }
    return $self
}

sub _build_subinfo     {
    my $self = shift;
    return [] unless $self->has_sub;
    my @info = Sub::Identify::get_code_info($self->sub);
    return [ $info[0], $info[1] eq '__ANON__' ? undef : $info[1] ];
}

sub _build_file        { my $self = shift; return $self->sub ? (Sub::Identify::get_code_location($self->sub))[0] : undef }
sub _build_line        { my $self = shift; return $self->sub ? (Sub::Identify::get_code_location($self->sub))[1] : undef }
sub _build_is_constant { my $self = shift; return $self->sub ? Sub::Identify::is_sub_constant($self->sub) : undef }
sub _build_prototype   { my $self = shift; return $self->sub ? Sub::Util::prototype($self->sub) : undef }
sub _build_attribute   { my $self = shift; return $self->sub ? [ attributes::get($self->sub) ] : undef }

sub apply_subname {
    my ($self, $subname) = @_;
    _croak 'apply_subname requires subroutine reference' unless $self->sub;
    $self->set_subname($subname);
    Sub::Util::set_subname($self->fullname, $self->sub);
    return $self;
}

sub apply_prototype {
    my ($self, $prototype) = @_;
    _croak 'apply_prototype requires subroutine reference' unless $self->sub;
    Sub::Util::set_prototype($prototype, $self->sub);
    $self->set_prototype($prototype);
    return $self;
}

sub apply_attribute {
    my ($self, @attribute) = @_;
    _croak 'apply_attribute requires subroutine reference' unless $self->sub;
    {
        no warnings qw(misc); ## no critic (ProhibitNoWarnings)
        attributes->import($self->stashname, $self->sub, @attribute);
    }
    $self->set_attribute($self->_build_attribute);
    return $self;
}

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

    $self->apply_subname($other->subname);
    $self->apply_prototype($other->prototype);
    $self->apply_attribute(@{$other->attribute});

    return $self;
}

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

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

    if ($self->has_subname) {
        return unless $self->subname eq $other->subname
    }
    else {
        return if $other->has_subname;
    }

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

    return unless $self->parameters->is_same_interface($other->parameters);

    return unless $self->returns->is_same_interface($other->returns);

    return !!1;
}

sub is_strict_same_interface;
*is_strict_same_interface = \&is_same_interface;

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

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

    if ($self->has_subname) {
        return unless $self->subname eq $other->subname
    }

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

    return unless $self->parameters->is_relaxed_same_interface($other->parameters);

    return unless $self->returns->is_relaxed_same_interface($other->returns);

    return !!1;
}

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

    my @src;

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

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

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

    push @src => $self->parameters->is_same_interface_inlined(sprintf('%s->parameters', $v));

    push @src => $self->returns->is_same_interface_inlined(sprintf('%s->returns', $v));

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

sub is_strict_same_interface_inlined;
*is_strict_same_interface_inlined = \&is_same_interface_inlined;

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

    my @src;

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

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

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

    push @src => $self->parameters->is_relaxed_same_interface_inlined(sprintf('%s->parameters', $v));

    push @src => $self->returns->is_relaxed_same_interface_inlined(sprintf('%s->returns', $v));

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

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

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

    if ($self->has_subname) {
        return sprintf('invalid subname. got: %s, expected: %s', $other->subname, $self->subname)
            unless $self->subname eq $other->subname
    }
    else {
        return sprintf('should not have subname. got: %s', $other->subname) if $other->has_subname;
    }

    return 'invalid method'
        unless $self->is_method eq $other->is_method;

    return "invalid parameters: " . $self->parameters->error_message($other->parameters)
        unless $self->parameters->is_same_interface($other->parameters);

    return "invalid returns: " . $self->returns->error_message($other->returns)
        unless $self->returns->is_same_interface($other->returns);

    return '';
}

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

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

    if ($self->has_subname) {
        return sprintf('invalid subname. got: %s, expected: %s', $other->subname, $self->subname)
            unless $self->subname eq $other->subname
    }

    return 'invalid method'
        unless $self->is_method eq $other->is_method;

    return "invalid parameters: " . $self->parameters->relaxed_error_message($other->parameters)
        unless $self->parameters->is_relaxed_same_interface($other->parameters);

    return "invalid returns: " . $self->returns->relaxed_error_message($other->returns)
        unless $self->returns->is_relaxed_same_interface($other->returns);

    return '';
}

sub display {
    my $self = shift;

    my $keyword = $self->is_method ? 'method' : 'sub';
    my $subname = $self->subname;

    my $s = $keyword;
    $s .= ' ' . $subname if $subname;
    $s .= '('. $self->parameters->display .')';
    $s .= ' => ' . $self->returns->display;
    return $s;
}

1;
__END__