view release on metacpan or  search on metacpan

lib/Sub/Meta.pm  view on Meta::CPAN

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

our $VERSION = "0.15";

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;
}