File Coverage

blib/lib/Var/Pairs.pm

Criterion	Covered	Total	%
statement	95	141	67.3
branch	27	50	54.0
condition	8	17	47.0
subroutine	19	22	86.3
pod	8	8	100.0
total	157	238	65.9

package Var::Pairs;

our $VERSION = '0.003004';

use 5.014;
use warnings;
no if $] >= 5.018, warnings => "experimental::smartmatch";
use Carp;
use Devel::Callsite;

# 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::invert       = \&Var::Pairs::invert;
        *Var::Pairs::autobox::invert_pairs = \&Var::Pairs::invert_pairs;
    }
}

# API...
my %EXPORTABLE;
@EXPORTABLE{qw< pairs kvs each_pair each_kv 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 (\[$@%];\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]\[$@%]) {
    require PadWalker;

    # Grab caller vars...
    my ($lexvars, $packvars)  = (PadWalker::peek_my(1), PadWalker::peek_our(1));

    # Reverse them (creating addr --> name mapping)
    my %varname = (reverse(%$packvars), reverse(%$lexvars));

    # Remove the name sigils...
    s/^.// for values %varname;

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

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

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

    # Grab caller vars...
    my ($lexvars, $packvars)  = (PadWalker::peek_my(1), PadWalker::peek_our(1));

    # Reverse them (creating addr --> name mapping)
    my %varname = (reverse(%$packvars), reverse(%$lexvars));

    # Remove the name sigils...
    s/^.// for values %varname;

    # Take each var ref and convert to 'name' => 'ref_or_val' pairs...
    return map { Var::Pairs::Pair->new($varname{$_} => (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() . $container_ref;

    # Build an iterator...
    $iterator_for{$ID} //= [ &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() . $container_ref;

    # Build an iterator...
    $iterator_for{$ID} //= [ &kvs ];

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



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

    given (ref($var_ref) || 'SCALAR') {
        when ('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;
                }
            }
        }
        when ('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;
                }
            }
        }
        default {
            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;

    # Iterator the requested iterator...
    my $each_pair = shift @{$iterator_for{$ID}};

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

    # Iterator the requested iterator...
    my @each_kv = splice @{$iterator_for{$ID}}, 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__