File Coverage

blib/lib/Var/Pairs.pm

Criterion	Covered	Total	%
statement	105	168	62.5
branch	41	92	44.5
condition	10	31	32.2
subroutine	23	31	74.1
pod	9	9	100.0
total	188	331	56.8

package Var::Pairs;
use 5.014;

our $VERSION = '0.004002';

use warnings;
no if $] >= 5.018, warnings => "experimental::smartmatch";
use Carp;
use Devel::Callsite;
use Scope::Upper qw< reap UP >;
use PadWalker qw< var_name >;

# Check for autoboxing, and set up pairs() method if applicable..
my $autoboxing;
BEGIN {
    if (eval{ require autobox }) {
        $autoboxing = 1;
        push @Var::Pairs::ISA, 'autobox';

        *Var::Pairs::autobox::pairs        = \&Var::Pairs::pairs;
        *Var::Pairs::autobox::kvs          = \&Var::Pairs::kvs;
        *Var::Pairs::autobox::each_pair    = \&Var::Pairs::each_pair;
        *Var::Pairs::autobox::each_kv      = \&Var::Pairs::each_kv;
        *Var::Pairs::autobox::each_value   = \&Var::Pairs::each_value;
        *Var::Pairs::autobox::invert       = \&Var::Pairs::invert;
        *Var::Pairs::autobox::invert_pairs = \&Var::Pairs::invert_pairs;
    }
}

# API...
my %EXPORTABLE;
@EXPORTABLE{qw< pairs kvs each_pair each_kv each_value to_kv to_pair invert invert_pairs >} = ();

sub import {
    my ($class, @exports) = @_;

    # Check for export requests...
    if (!@exports) {
        @exports = keys %EXPORTABLE;
    }
    else {
        my @bad = grep { !exists $EXPORTABLE{$_} } @exports;
        carp 'Unknown subroutine' . (@bad==1 ? q{} : q{s})  . " requested: @bad"
            if @bad;
    }

    # Export API...
    no strict 'refs';
    my $caller = caller;
    for my $subname (@exports) {
        no strict 'refs';
        *{$caller.'::'.$subname} = \&{$subname};
    }

    # Enable autoboxing of ->pairs() in caller's lexical scope, if possible...
    if ($autoboxing) {
        $class->SUPER::import(
            HASH  => 'Var::Pairs::autobox',
            ARRAY => 'Var::Pairs::autobox',
        );
    }
}

# Track iterators for each call...
state %iterator_for;

# Convert one or more vars into a ('varname', $varname,...) list...

sub to_kv (\[$@%];\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]) {

    # Take each var ref and convert to 'name' => 'ref_or_val' pairs...
    return map { my $name = var_name(1, $_); $name =~ s/^.//;
                 $name => (ref($_) =~ /SCALAR|REF/ ? $$_ : $_)
               } @_;
}

# Convert one or more vars into 'varname' => $varname pairs...

sub to_pair (\[$@%];\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]) {

    return map { my $name = var_name(1, $_); $name =~ s/^.//;
                 Var::Pairs::Pair->new($name => (ref($_) =~ /SCALAR|REF/ ? $$_ : $_), 'none')
               } @_;
}


# Generate pairs for iterating hashes and arrays...
sub pairs (+) {
    if (!defined wantarray) {
        croak("Useless use of pairs() in void context");
    }
    elsif (!wantarray) {
        croak("Invalid call to pairs() in scalar context.\nDid you mean each_pair()?\nError")
    }

    my $container_ref = shift;
    my $container_type = ref $container_ref || 'scalar value';

    # Verify the single argument...
    if ($container_type !~ m{^ARRAY$|^HASH$}) {
        croak "Argument to pairs() must be array or hash (not \L$container_type\E)";
    }

    # Uniquely identify this call, according to its lexical context...
    my $ID = callsite() . context() . $container_ref;

    # Short-circuit if this is a repeated call...
    if (!wantarray && $iterator_for{$ID}) {
        return _get_each_pair($ID);
    }

    # Generate the list of pairs, according to the container type...
    my $container_is_array = $container_type eq 'ARRAY';
    my @pairs = map { Var::Pairs::Pair->new($_, $container_ref, $container_is_array ? 'array' : 'hash') }
                    $container_is_array ? 0..$#{$container_ref} : keys %{$container_ref};

    # Return them all in list context...
    return @pairs;

    # In scalar context, return the first pair, remembering the rest...
    $iterator_for{$ID} = \@pairs;
    return shift @pairs;
}

sub each_pair (+) {
    my ($container_ref) = @_;

    # Uniquely identify this call, according to its lexical context...
    my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});

    # Install a destructor for it at the send of the caller's block...
    reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
        if !$iterator_for{$ID};

    # Build an iterator...
    $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
                                ? sub {
                                    state $n=0;
                                    my ($next) = $container_ref->() or return;
                                    return ($n++, $next);
                                  }
                                : [ &pairs ];

    # Iterate...
    return _get_each_pair($ID);
}

# Generate key, value,... lists for iterating hashes and arrays...
sub kvs (+) {
    if (!defined wantarray) {
        croak("Useless use of kvs() in void context");
    }
    elsif (!wantarray) {
        croak("Invalid call to kvs() in scalar context.\nDid you mean each_kv()?\nError")
    }

    my $container_ref = shift;
    my $container_type = ref $container_ref || 'scalar value';

    # Verify the single argument...
    if ($container_type !~ m{^ARRAY$|^HASH$}) {
        croak "Argument to pairs() must be array or hash (not \L$container_type\E)";
    }

    # Uniquely identify this call, according to its lexical context...
    my $ID = callsite() . context() . $container_ref;

    # Return the key/value list, according to the container type...
    if ($container_type eq 'ARRAY') {
        return map { ($_, $container_ref->[$_]) } 0..$#{$container_ref};
    }
    else {
        return %{$container_ref};
    }
}

sub each_kv (+) {
    my ($container_ref) = @_;

    # Uniquely identify this call, according to its lexical context and iteration target...
    my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});

    # Install a destructor for it at the send of the caller's block...
    reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
        if !$iterator_for{$ID};

    $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
                                ? sub {
                                    state $n=0;
                                    my ($next) = $container_ref->() or return;
                                    return ($n++, $next);
                                  }
                                : [ &kvs ];

    # Iterate...
    return _get_each_kv($ID);
}

# Iterate just the values of a container...
sub each_value (+) {
    my ($container_ref) = @_;

    # Uniquely identify this call, according to its lexical context and iteration target...
    my $ID = callsite() . context() . (ref($_[0]) && var_name(1,$_[0]) ? $container_ref : q{});

    # Install a destructor for it at the send of the caller's block...
    reap { delete $iterator_for{$ID} if exists $iterator_for{$ID} } UP UP
        if !$iterator_for{$ID};

    $iterator_for{$ID} //= ref($container_ref) eq 'CODE'
                                ? sub {
                                    state $n=0;
                                    my ($next) = $container_ref->() or return;
                                    return ($n++, $next);
                                  }
                                : [ &kvs ];

    # Iterate...
    my @next = _get_each_kv($ID) or return;
    return $next[1];
}

# Invert the key=>values of a hash or array...

sub invert (+) {
    goto &_invert;
}

sub invert_pairs (+) {
    push @_, 1;
    goto &_invert;
}


# Utilities...

# Perform var inversions...

sub _invert {
    my ($var_ref, $return_as_pairs) = @_;
    my %inversion;

    if (!defined wantarray) {
        croak 'Useless use of invert() in void context';
    }
    elsif (!wantarray) {
        croak 'Invalid call to invert() in scalar context';
    }

    for my $var_type (ref($var_ref) || 'SCALAR') {
        if ($var_type eq 'HASH') {
            for my $key (keys %{$var_ref}) {
                my $values = $var_ref->{$key};
                for my $value ( ref $values eq 'ARRAY' ? @$values : $values ) {
                    $inversion{$value} //= [];
                    push @{$inversion{$value}}, $key;
                }
            }
        }
        elsif ($var_type eq 'ARRAY') {
            for my $key (0..$#{$var_ref}) {
                my $values = $var_ref->[$key];
                for my $value ( ref $values eq 'ARRAY' ? @$values : $values ) {
                    $inversion{$value} //= [];
                    push @{$inversion{$value}}, $key;
                }
            }
        }
        else {
            croak "Argument to invert() must be hash or array (not \L$_\E)";
        }
    }

    return $return_as_pairs ? pairs %inversion : %inversion;
}

# Iterate, cleaning up if appropriate...
sub _get_each_pair {
    my $ID = shift;

    # Iterate the requested iterator...
    my $iterator = $iterator_for{$ID};
    my $each_pair;
    if (ref($iterator) eq 'CODE') {
        my @kv = $iterator->();
        $each_pair = Var::Pairs::Pair->new(@kv, 'none') if @kv;
    }
    else {
        $each_pair = shift @{$iterator};
    }

    # If nothing was left to iterate, clean up the empty iterator...
    if (!defined $each_pair) {
        delete $iterator_for{$ID};
    }

    return $each_pair;
}

sub _get_each_kv {
    my $ID = shift;

    # Iterate the requested iterator...
    my $iterator = $iterator_for{$ID};
    my @each_kv = ref($iterator) eq 'CODE'
                    ? $iterator->()
                    : splice @{$iterator}, 0, 2;

    # If nothing was left to iterate, clean up the empty iterator...
    if (!@each_kv) {
        delete $iterator_for{$ID};
    }

    # Return key or key/value, as appropriate (a la each())...
    return wantarray ? @each_kv : $each_kv[0];
}

use if $] <  5.022, 'Var::Pairs::Pair_DataAlias';
use if $] >= 5.022, 'Var::Pairs::Pair_BuiltIn';

1; # Magic true value required at end of module
__END__