File Coverage

blib/lib/Function/Parameters.pm

Criterion	Covered	Total	%
statement	202	214	94.3
branch	88	110	80.0
condition	12	16	75.0
subroutine	31	33	93.9
pod	0	1	0.0
total	333	374	89.0

package Function::Parameters;

use v5.14.0;
use warnings;
use warnings::register;

use Carp qw(croak confess);
use Scalar::Util qw(blessed);

sub _croak {
    my (undef, $file, $line) = caller 1;
    die @_, " at $file line $line.\n";
}

use XSLoader;
BEGIN {
    our $VERSION = '2.002004';
    #$VERSION =~ s/-TRIAL[0-9]*\z//;
    XSLoader::load;
}

sub _warn_config_not_a_reference {
    warnings::warnif sprintf q{%s: $^H{'%s'} is not a reference; skipping: %s}, __PACKAGE__, HINTK_CONFIG, $^H{+HINTK_CONFIG};
}

sub _assert_valid_identifier {
    my ($name, $with_dollar) = @_;
    my $bonus = $with_dollar ? '\$' : '';
    $name =~ /\A${bonus}[^\W\d]\w*\z/
        or confess qq{"$name" doesn't look like a valid identifier};
}

sub _assert_valid_attributes {
    my ($attrs) = @_;
    $attrs =~ m{
        \A \s*+
        : \s*+
        (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
        (?:
            (?: : \s*+ )?
            (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
        )*+
        \z

        (?(DEFINE)
            (?
                [^\W\d]
                \w*+
            )
            (?
                \(
                [^()\\]*+
                (?:
                    (?:
                        \\ .
                    |
                        (?¶m)
                    )
                    [^()\\]*+
                )*+
                \)
            )
        )
    }sx or confess qq{"$attrs" doesn't look like valid attributes};
}

sub _reify_type_moose {
    require Moose::Util::TypeConstraints;
    Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
}

sub _malformed_type {
    my ($type, $msg) = @_;
    my $pos = pos $_[0];
    substr $type, $pos, 0, ' <-- HERE ';
    croak "Malformed type: $msg marked by <-- HERE in '$type'";
}

sub _reify_type_auto_parameterized {
    # (str, caller)
    $_[0] =~ /\G ( \w+ (?: :: \w+)* ) \s* /xgc or _malformed_type $_[0], "missing type name";
    my $name = $1;
    $name = "$_[1]::$name" unless $name =~ /::/;
    my $fun = do {
        no strict 'refs';
        defined &$name or croak "Undefined type name $name";
        \&$name
    };

    $_[0] =~ /\G \[ \s* /xgc
        or return $fun;

    my @args;
    until ($_[0] =~ /\G \] \s* /xgc) {
        $_[0] =~ /\G , \s* /xgc or _malformed_type $_[0], "missing ',' or ']'"
            if @args;
        push @args, &_reify_type_auto_union;
    }

    sub { $fun->([map $_->(), @args]) }
}

sub _reify_type_auto_term {
    # (str, caller)
    my $compl = 0;
    while ($_[0] =~ /\G ~ \s* /xgc) {
        $compl++;
    }

    my $inner;
    if ($_[0] =~ /\G \( \s* /xgc) {
        $inner = &_reify_type_auto_union;
        $_[0] =~ /\G \) \s* /xgc or _malformed_type $_[0], "missing ')'";
    } else {
        $inner = &_reify_type_auto_parameterized;
    }

    !$compl
        ? $inner
        : sub {
            my $t = $inner->();
            for my $i (1 .. $compl) {
                $t = ~$t;
            }
            $t
        }
}

sub _reify_type_auto_alternative {
    # (str, caller)
    my $fun = &_reify_type_auto_term;
    while ($_[0] =~ m!\G / \s* !xgc) {
        my $right = &_reify_type_auto_term;
        my $left  = $fun;
        $fun = sub { $left->() / $right->() };
    }
    $fun
}

sub _reify_type_auto_intersection {
    # (str, caller)
    my $fun = &_reify_type_auto_alternative;
    while ($_[0] =~ /\G & \s* /xgc) {
        my $right = &_reify_type_auto_alternative;
        my $left  = $fun;
        $fun = sub { $left->() & $right->() };
    }
    $fun
}

sub _reify_type_auto_union {
    # (str, caller)
    my $fun = &_reify_type_auto_intersection;
    while ($_[0] =~ /\G \| \s* /xgc) {
        my $right = &_reify_type_auto_intersection;
        my $left  = $fun;
        $fun = sub { $left->() | $right->() };
    }
    $fun
}

sub _reify_type_auto {
    my ($type) = @_;
    my $caller = caller;

    $type =~ /\G \s+ /xgc;
    my $tfun = _reify_type_auto_union $type, $caller;
    $type =~ /\G \z/xgc or _malformed_type $type, "trailing garbage";
    $tfun->()
}

sub _delete_default {
    my ($href, $key, $default) = @_;
    exists $href->{$key} ? delete $href->{$key} : $default
}

sub _find_or_add_idx {
    my ($array, $x) = @_;
    my $index;
    for my $i (0 .. $#$array) {
        if ($array->[$i] == $x) {
            $index = $i;
            last;
        }
    }
    unless (defined $index) {
        $index = @$array;
        push @$array, $x;
    }
    $index
}

my %type_map = (
    function_strict    => {},
    function_lax       => {
        defaults   => 'function_strict',
        strict     => 0,
    },
    function           => { defaults => 'function_strict' },

    method_strict      => {
        defaults   => 'function_strict',
        attributes => ':method',
        shift      => '$self',
        invocant   => 1,
    },
    method_lax         => {
        defaults   => 'method_strict',
        strict     => 0,
    },
    method             => { defaults => 'method_strict' },

    classmethod_strict => {
        defaults   => 'method_strict',
        shift      => '$class',
    },
    classmethod_lax    => {
        defaults   => 'classmethod_strict',
        strict     => 0,
    },
    classmethod        => { defaults => 'classmethod_strict' },

    around             => {
        defaults    => 'method',
        name        => 'required',
        install_sub => 'around',
        shift       => ['$orig', '$self'],
        runtime     => 1,
    },
    (
        map +(
            $_ => {
                defaults    => 'method',
                name        => 'required',
                install_sub => $_,
                runtime     => 1,
            }
        ), qw(
            before after augment override
        ),
    ),
);

my %import_map = (
    fun => 'function',
    (
        map +($_ => $_),
        qw(
            method
            classmethod
            before
            after
            around
            augment
            override
        )
    ),

    ':strict' => {
        fun    => 'function_strict',
        method => 'method_strict',
    },

    ':lax' => {
        fun    => 'function_lax',
        method => 'method_lax',
    },

    ':std' => [qw(fun method)],
    ':modifiers' => [qw(
        before
        after
        around
        augment
        override
    )],
);
for my $v (values %import_map) {
    if (ref $v eq 'ARRAY') {
        $v = {
            map +($_ => $import_map{$_} || die "Internal error: $v => $_"),
            @$v
        };
    }
}

sub import {
    my $class = shift;

    my %imports;
    @_ = qw(:std) if !@_;
    for my $item (@_) {
        my $part;
        if (ref $item) {
            $part = $item;
        } else {
            my $type = $import_map{$item}
                or croak qq{"$item" is not exported by the $class module};
            $part = ref $type
                ? $type
                : { $item => $type };
        }
        @imports{keys %$part} = values %$part;
    }

    my %spec;

    for my $name (sort keys %imports) {
        _assert_valid_identifier $name;
        my $proto_type = $imports{$name};

        $proto_type = {defaults => $proto_type} unless ref $proto_type;

        my %type = %$proto_type;
        while (my $defaults = delete $type{defaults}) {
            my $base = $type_map{$defaults}
                or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})];
            %type = (%$base, %type);
        }

        if (exists $type{strict}) {
            $type{check_argument_count} ||= $type{strict};
            delete $type{strict};
        }

        my %clean;

        $clean{name} = delete $type{name} // 'optional';
        $clean{name} =~ /\A(?:optional|required|prohibited)\z/
            or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];

        $clean{attrs} = delete $type{attributes} // '';
        _assert_valid_attributes $clean{attrs} if $clean{attrs};

        if (!exists $type{reify_type}) {
            $clean{reify_type} = \&_reify_type_auto;
        } else {
            my $rt = delete $type{reify_type} // '(undef)';
            if (!ref $rt) {
                $rt =
                    $rt eq 'auto'  ? \&_reify_type_auto :
                    $rt eq 'moose' ? \&_reify_type_moose :
                    confess qq{"$rt" isn't a known predefined type reifier};
            } elsif (ref $rt ne 'CODE') {
                confess qq{"$rt" doesn't look like a type reifier};
            }

            $clean{reify_type} = $rt;
        }

        if (!exists $type{install_sub}) {
            $clean{install_sub} = '';
        } else {
            my $is = delete $type{install_sub};
            if (!ref $is) {
                _assert_valid_identifier $is;
            } elsif (ref $is ne 'CODE') {
                confess qq{"$is" doesn't look like a sub installer};
            }

            $clean{install_sub} = $is;
        }

        $clean{shift} = do {
            my $shift = delete $type{shift} // [];
            $shift = [$shift] if !ref $shift;
            my $str = '';
            my @shifty_types;
            for my $item (@$shift) {
                my ($name, $type);
                if (ref $item) {
                    @$item == 2 or confess "A 'shift' item must have 2 elements, not " . @$item;
                    ($name, $type) = @$item;
                } else {
                    $name = $item;
                }
                _assert_valid_identifier $name, 1;
                $name eq '$_' and confess q[Using "$_" as a parameter is not supported];
                $str .= $name;
                if (defined $type) {
                    blessed($type) or confess "${name}'s type must be an object, not $type";
                    my $index = _find_or_add_idx \@shifty_types, $type;
                    $str .= "/$index";
                }
                $str .= ' ';
            }
            $clean{shift_types} = \@shifty_types;
            $str
        };

        $clean{default_arguments}    = _delete_default \%type, 'default_arguments',    1;
        $clean{named_parameters}     = _delete_default \%type, 'named_parameters',     1;
        $clean{types}                = _delete_default \%type, 'types',                1;
        $clean{invocant}             = _delete_default \%type, 'invocant',             0;
        $clean{runtime}              = _delete_default \%type, 'runtime',              0;
        $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 1;
        $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1;

        %type and confess "Invalid keyword property: @{[sort keys %type]}";

        $spec{$name} = \%clean;
    }

    my %config = %{$^H{+HINTK_CONFIG} // {}};
    for my $kw (keys %spec) {
        my $type = $spec{$kw};

        my $flags =
            $type->{name} eq 'prohibited' ? FLAG_ANON_OK                :
            $type->{name} eq 'required'   ? FLAG_NAME_OK                :
                                            FLAG_ANON_OK | FLAG_NAME_OK
        ;
        $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments};
        $flags |= FLAG_CHECK_NARGS  if $type->{check_argument_count};
        $flags |= FLAG_CHECK_TARGS  if $type->{check_argument_types};
        $flags |= FLAG_INVOCANT     if $type->{invocant};
        $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters};
        $flags |= FLAG_TYPES_OK     if $type->{types};
        $flags |= FLAG_RUNTIME      if $type->{runtime};
        $config{$kw} = {
            HINTSK_FLAGS, => $flags,
            HINTSK_SHIFT, => $type->{shift},
            HINTSK_ATTRS, => $type->{attrs},
            HINTSK_REIFY, => $type->{reify_type},
            HINTSK_INSTL, => $type->{install_sub},
            !@{$type->{shift_types}} ? () : (
                HINTSK_SHIF2, => $type->{shift_types},
            ),
        };
    }
    $^H{+HINTK_CONFIG} = \%config;
}

sub unimport {
    my $class = shift;

    if (!@_) {
        delete $^H{+HINTK_CONFIG};
        return;
    }

    my %config = %{$^H{+HINTK_CONFIG}};
    delete @config{@_};
    $^H{+HINTK_CONFIG} = \%config;
}


our %metadata;

sub _register_info {
    my (
        $key,
        $declarator,
        $shift,
        $positional_required,
        $positional_optional,
        $named_required,
        $named_optional,
        $slurpy,
        $slurpy_type,
    ) = @_;

    my $info = {
        declarator => $declarator,
        shift => $shift,
        positional_required => $positional_required,
        positional_optional => $positional_optional,
        named_required => $named_required,
        named_optional => $named_optional,
        slurpy => defined $slurpy ? [$slurpy, $slurpy_type] : undef,
    };

    $metadata{$key} = $info;
}

sub _mkparam1 {
    my ($pair) = @_;
    my ($v, $t) = @{$pair || []} or return undef;
    Function::Parameters::Param->new(
        name => $v,
        type => $t,
    )
}

sub _mkparams {
    my @r;
    while (my ($v, $t) = splice @_, 0, 2) {
        push @r, Function::Parameters::Param->new(
            name => $v,
            type => $t,
        );
    }
    \@r
}

sub info {
    my ($func) = @_;
    my $key = _cv_root $func or return undef;
    my $info = $metadata{$key} or return undef;
    require Function::Parameters::Info;
    Function::Parameters::Info->new(
        keyword  => $info->{declarator},
        nshift   => $info->{shift},
        slurpy   => _mkparam1($info->{slurpy}),
        (
            map +("_$_" => _mkparams @{$info->{$_}}),
            qw(
                positional_required
                positional_optional
                named_required
                named_optional
            )
        )
    )
}

'ok'

__END__