view release on metacpan or  search on metacpan

lib/Data/Bind.pm  view on Meta::CPAN

        my $inv  = ref($arg->[0]) && ref($arg->[0]) eq 'ARRAY' ? undef : shift @$arg;
        last unless defined $inv || @$arg;
        my $pos = shift @$arg;
        my $named = shift @$arg;

        if ($multidim) {
            push @x, \Data::Capture::Overload->new( { invocant => $inv, positional => $pos, named => $named });
        }
        else {
            die 'wrong dimension' unless $self->[$i];
            push @install_local,
                @{ $self->[$i++]->bind({ invocant => $inv, positional => $pos, named => $named }, $lv) };
        }
    }

    if ($multidim) {
        $self->[0]->bind( { positional => \@x }, $lv );
    }

    return \@install_local;
}


sub is_compatible {
    my $self = shift;
    no warnings 'redefine';
    local *Data::Bind::Param::slurpy_bind = sub {};
    local *Data::Bind::Param::bind = sub {};
    local *Data::Bind::Array::bind = sub {};
    local $@;
    eval { $self->bind_all(\@_) };
    return $@ ? 0 : 1;
}

sub bind {
    # XXX: old api
    my $self = shift;
    die 'old api used with multidimension sig' if $#{$self};
    $self->[0]->bind($_[0], $_[1] || 2);
}

sub prepare_binding {
    shift->[0]->prepare_binding(@_);
}

sub finalize_binding {
    my ( $self, $binding, $lv ) = @_;
    $lv ||= 1;
    $self->[0]->finalize_binding($binding, $lv + 1);
}

sub all_variable_names {
    my %seen; grep { !$seen{$_}++ or die "duplicate variable $_ in signature" } $_[0][0]->all_variable_names;
}

package Data::Bind::Sig;
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(qw(positional invocant named named_slurpy is_multidimension));
use Carp qw(croak);
use Scalar::Util qw(blessed);
use PadWalker qw(peek_my);

use Data::Capture;

sub bind {
    my ( $self, $args, $lv ) = @_;
    $lv ||= 1;
    $self->finalize_binding( $self->prepare_binding(Data::Capture->new($args)), $lv + 1 );
}

sub prepare_binding {
    my ($self, $capture, %opts) = @_;
    local $Carp::CarpLevel = 2;

    my %bound;

    my $named_arg = $capture->named;

    my $bindings;

	# FIXME invocant should be ref, it's writable in perl5
    if ($self->invocant) {
        croak 'invocant missing'
            if !defined $capture->invocant;

        $bindings->{$self->invocant->container_var} = [ $self->invocant, \$capture->invocant ];
    }
    else {
        croak 'unexpected invocant'
            if defined $capture->invocant;
    }

    for my $param_name (keys %{$self->named || {}}) {
        my $param = $self->named->{$param_name};
        if (my $current = delete $named_arg->{$param_name}) {
            # XXX: handle array concating
            $bindings->{ $param->container_var } = [ $param, $current ];
            $bound{$param_name}++;
        }
        elsif ($param->default) {
            $bindings->{ $param->container_var } = [ $param, $opts{no_defaults} ? undef : \$param->default->(), 'default' ];
        }
        elsif ($param->named_only) {
            croak "named argument ".$param->name." is required"
                unless $param->is_optional;
        }
     }

    if ($self->named_slurpy) {
        $bindings->{ $self->named_slurpy->container_var  } =
            [ $self->named_slurpy, $named_arg, 'slurpy' ];
    }
    else {
        # XXX: report extra incoming named args
    }

    my $pos_arg = $capture->positional;
    for my $param (@{$self->positional || []}) {
        if ($param->is_slurpy && $param->p5type ne '$') {
            $bindings->{ $param->container_var } = [ $param, $pos_arg, 'slurpy' ];
            $pos_arg = [];