Var-Pairs-0.004001/000755 000765 000024 00000000000 13274615570 014150 5ustar00damianstaff000000 000000 Var-Pairs-0.004001/Changes000644 000765 000024 00000006345 13274615566 015460 0ustar00damianstaff000000 000000 Revision history for Var-Pairs 0.000001 Fri May 25 06:52:11 2012 Initial release. 0.001000 Wed Jul 18 13:54:16 2012 First public release 0.001001 Wed Jul 18 13:55:31 2012 Update README 0.001002 Sat Mar 23 07:58:28 2013 Removed autobox dependency for t/kvs.t (Thanks Salvatore!) 0.001003 Thu Aug 8 11:46:09 2013 Converted to use Devel::Callsite instead of Scope::Upper in order to identify caller location for the each_... family of functions. 0.001005 Tue Mar 11 10:17:52 2014 Added export controls (thanks Rob) 0.002000 Sat Apr 5 17:19:03 2014 Converted Pair class to array-based for a 50% speed-up (thanks Toby!) Added ->kv() to Pair type (thanks Toby) 0.002001 Wed Mar 11 20:04:58 2015 Swapped a doc nit (thanks Garry!) Documented non-resettable nature of each_kv() iterators (i.e. they don't reset when the original hash is key()'d) (thanks John) Allowed each_kv to work correctly on different containers that are passed to the same call: each_kv( %{$some_ref} ) (thanks John!) 0.002002 Wed Mar 11 20:13:33 2015 Allowed each_pair and pairs to also work correctly on different containers that are passed to the same call 0.002003 Wed Mar 11 20:42:14 2015 Fixed brittle testing approach in t/each_via_ref.t (Thanks Slaven!) Neutralized irritating experimental warnings on reference operations (Thanks Slaven) 0.002004 Wed Mar 11 21:01:52 2015 Sigh. Tweak experimentals warnings for 5.18. (Thanks again Slaven) 0.003000 Sat Aug 20 12:04:59 2016 Strip out autoderefs to continue working under 5.23+ (thanks, Slaven) Improve identification of each unique context (by adding use of context()) Refactor Var::Pairs::Pair to avoid use of Data::Alias under Perl 5.24+ (thanks Salvatore) 0.003002 Sat Aug 20 16:49:20 2016 Updated MANIFEST Documented reliance on Data::Alias 0.003004 Sat Aug 20 19:18:50 2016 Adjusted requirement for Data::Alias down to pre-5.22 0.003005 Mon May 7 06:55:18 2018 Made each_pair() and each_kv() clean themselves up at the end of their caller's block, to solve the "last of out a loop messes up the iterator" problem. (Thanks, Rolf!) 0.004000 Mon May 7 15:44:52 2018 Allowed each_pair() and each_kv() to take a subroutine as an iterator. Added each_value() to return just the value iterated without returning the key. INCOMPATIBLE CHANGE: Improved behaviour of each_pair() and each_kv(). Now they differentiate between: while (my $pair = each_pair $NAMED_CONTAINER) {...} and: while (my $pair = each_pair EXPRESSION_PRODUCING_CONTAINER_REF) {...} If the container is NOT passed in a named variable (i.e. as a simple scalar, array, or hash variable), then the iteration is NOT specific to the container, only to the location. In other words, when the argument is an expression, the value of that expression is only significant at the beginning of the iteration loop; if it changes during the loop, the changes are ignored. This produces a lot more "do-what-I-mean"-ness. 0.004001 Wed May 9 18:01:58 2018 POD fix (thanks, Salvatore) Var-Pairs-0.004001/lib/000755 000765 000024 00000000000 13274615570 014716 5ustar00damianstaff000000 000000 Var-Pairs-0.004001/Makefile.PL000644 000765 000024 00000001272 13273753331 016121 0ustar00damianstaff000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Var::Pairs', AUTHOR => 'Damian Conway ', VERSION_FROM => 'lib/Var/Pairs.pm', ABSTRACT_FROM => 'lib/Var/Pairs.pm', PL_FILES => {}, LICENSE => 'perl', PREREQ_PM => { 'Test::More' => 0, 'Devel::Callsite' => 0.06, 'Scope::Upper' => 0, ($] < 5.022 ? ('Data::Alias' => 1.16) : ()), 'PadWalker' => 1.93, 'experimental' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Var-Pairs-*' }, ); Var-Pairs-0.004001/MANIFEST000644 000765 000024 00000001074 13274615571 015304 0ustar00damianstaff000000 000000 Changes MANIFEST Makefile.PL README lib/Var/Pairs.pm lib/Var/Pairs/Pair_BuiltIn.pm lib/Var/Pairs/Pair_DataAlias.pm t/00.load.t t/array.t t/array_while.t t/arrayref.t t/autobox.t t/coercions.t t/diagnostics.t t/hash.t t/hash_while.t t/hashref.t t/kv.t t/kvs.t t/lvalue.t t/nested.t t/nested_kv.t t/one_liner.t t/to_pair.t t/nexted_kv_same_statement.t t/hash_while_kv.t t/each_via_ref.t t/array_while_kv.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Var-Pairs-0.004001/META.json000644 000765 000024 00000002061 13274615570 015570 0ustar00damianstaff000000 000000 { "abstract" : "OO iterators and pair constructors for variables", "author" : [ "Damian Conway " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Var-Pairs", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Data::Alias" : "1.16", "Devel::Callsite" : "0.06", "PadWalker" : "1.93", "Scope::Upper" : "0", "Test::More" : "0", "experimental" : "0" } } }, "release_status" : "stable", "version" : "0.004001" } Var-Pairs-0.004001/META.yml000644 000765 000024 00000001163 13274615570 015422 0ustar00damianstaff000000 000000 --- abstract: 'OO iterators and pair constructors for variables' author: - 'Damian Conway ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Var-Pairs no_index: directory: - t - inc requires: Data::Alias: '1.16' Devel::Callsite: '0.06' PadWalker: '1.93' Scope::Upper: '0' Test::More: '0' experimental: '0' version: '0.004001' Var-Pairs-0.004001/README000644 000765 000024 00000001267 13274615566 015043 0ustar00damianstaff000000 000000 Var::Pairs version 0.004001 This module exports a small number of subroutines that add some Perl 6 conveniences to Perl 5. Specifically, the module exports several subroutines that simplify interactions with key/value pairs in hashes and arrays. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2012, Damian Conway This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Var-Pairs-0.004001/t/000755 000765 000024 00000000000 13274615570 014413 5ustar00damianstaff000000 000000 Var-Pairs-0.004001/t/00.load.t000644 000765 000024 00000000167 11757521036 015736 0ustar00damianstaff000000 000000 use Test::More tests => 1; BEGIN { use_ok( 'Var::Pairs' ); } diag( "Testing Var::Pairs $Var::Pairs::VERSION" ); Var-Pairs-0.004001/t/array.t000644 000765 000024 00000000445 11757521065 015720 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 12; use Var::Pairs; my @data = 'a'..'f'; for my $next (pairs @data) { state $count = 0; ok $next->index == $count => 'index method correct'; ok $next->value eq $data[$count] => 'value method correct'; $count++; } Var-Pairs-0.004001/t/array_while.t000644 000765 000024 00000001504 13273754200 017077 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 34; use Var::Pairs; my @data = 'a'..'f'; while (my $next = each_pair @data) { state $count = 0; ok $next->index == $count => 'index method correct'; ok $next->value eq $data[$count] => 'value method correct'; $count++; END { ok $count == @data => 'correct number of iterations'; } } # Test that iterators in nested loops also reset... my $recount = 0; for (1..2) { my $count = 0; while (my $next = each_pair @data) { ok $next->index == $count => 'nested index method correct'; ok $next->value eq $data[$count] => 'nested value method correct'; $count++; $recount++; last if $count > 4; } } ok $recount == 10 => 'correct number of re-iterations'; Var-Pairs-0.004001/t/array_while_kv.t000644 000765 000024 00000001546 13273755462 017620 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 34; use Var::Pairs; my @data = 'a'..'f'; while (my ($next_index, $next_value) = each_kv @data) { state $count = 0; ok $next_index == $count => 'index method correct'; ok $next_value eq $data[$count] => 'value method correct'; $count++; END { ok $count == @data => 'correct number of iterations'; } } # Test that iterators in nested loops also reset... my $recount = 0; for (1..2) { my $count = 0; while (my ($next_index, $next_value) = each_kv @data) { ok $next_index == $count => 'nested index method correct'; ok $next_value eq $data[$count] => 'nested value method correct'; $count++; $recount++; last if $count > 4; } } ok $recount == 10 => 'correct number of re-iterations'; Var-Pairs-0.004001/t/arrayref.t000644 000765 000024 00000000471 11757521071 016411 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 12; use Var::Pairs; my $data_ref = ['a'..'f']; for my $next (pairs $data_ref) { state $count = 0; ok $next->index == $count => 'index method correct'; ok $next->value eq $data_ref->[$count] => 'value method correct'; $count++; } Var-Pairs-0.004001/t/autobox.t000644 000765 000024 00000001437 12755734777 016304 0ustar00damianstaff000000 000000 use 5.014; no if $] >= 5.018, warnings => "experimental::smartmatch"; use Test::More; plan eval { require autobox } ? (tests => 25) : (skip_all => 'This test requires autobox, which could not be loaded'); use Var::Pairs; my @data = 'a'..'f'; for my $next (@data->pairs) { state $count = 0; ok $next->index == $count => 'index method correct'; ok $next->value eq $data[$count] => 'value method correct'; $count++; } my $data_ref = {}; @{$data_ref}{1..6} = ('a'..'f'); while (my $next = $data_ref->each_pair) { ok $next->key ~~ $data_ref => 'key method correct'; ok $next->value eq $data_ref->{$next->key} => 'value method correct'; delete $data_ref->{$next->key}; } ok !keys %{$data_ref} => 'Iterated all'; Var-Pairs-0.004001/t/coercions.t000644 000765 000024 00000001220 11757521075 016557 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 24; use Var::Pairs; my %data; @data{1..6} = ('a', 2, 'c', 4, 'e', 6); for my $next (pairs %data) { ok $next => 'Pair boolified as expected'; if ($next->key % 2) { is "$next", $next->key . ' => "' . $next->value . '"' => 'Stringified as expected'; } else { is "$next", $next->key . ' => ' . $next->value => 'Stringified as expected'; } ok !defined eval { 0 + $next } => 'Failed to numerify (as expected)'; like $@, qr/Can't convert Pair\(.*?\) to a number/ => 'Appropriate error message'; } Var-Pairs-0.004001/t/diagnostics.t000644 000765 000024 00000003426 11776226133 017112 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 6; use Var::Pairs; subtest 'pairs() expects hash or array' => sub { ok !eval{ my @pairs = pairs sub{} } => 'Failed when given bad ref'; like $@, qr/Argument to pairs\(\) must be array or hash \(not code\)/ => 'Correct error message'; }; subtest 'pairs expects a containers, not a scalar' => sub { ok !eval{ my @pairs = pairs 'string' } => 'Failed when given non-container'; like $@, qr/Argument to pairs\(\) must be array or hash \(not scalar value\)/ => 'Correct error message'; }; subtest "Pairs don't numerify when value is number" => sub { my @pairs = pairs { a=>1, b=>2, c=>3}; ok !eval{ 0 + $pairs[0] } => 'Failed when numerifying pair'; like $@, qr/Can't convert Pair\([abc] => [123]\) to a number/ => 'Correct error message'; }; subtest "Pairs don't numerify when value is string" => sub { my @pairs = pairs { a=>'x', b=>'y', c=>'z'}; ok !eval{ 0 + $pairs[0] } => 'Failed when numerifying pair'; like $@, qr/Can't convert Pair\([abc] => "[xyz]"\) to a number/ => 'Correct error message'; }; subtest "Pairs don't numerify when value is ref" => sub { my @pairs = pairs { a=>['x','y'], b=>['x','y'], c=>['x','y']}; ok !eval{ 0 + $pairs[0] } => 'Failed when numerifying pair'; like $@, qr/Can't convert Pair\([abc] => ARRAY\) to a number/ => 'Correct error message'; }; subtest "Can't call pairs in non-list contexts" => sub { my $pairs = eval{ pairs { a=>['x','y'], b=>['x','y'], c=>['x','y']} }; like $@, qr/Invalid call to pairs\(\) in scalar context/ => 'Correct error message in scalar context'; eval{ pairs [1..10] }; like $@, qr/Useless use of pairs\(\) in void context/ => 'Correct error message in void context'; }; Var-Pairs-0.004001/t/each_via_ref.t000644 000765 000024 00000001744 13274011034 017162 0ustar00damianstaff000000 000000 use 5.014; no if $] >= 5.018, warnings => "experimental::smartmatch"; use strict; use Test::More tests => 24; use Var::Pairs; my %data1 = ( 1 => 'a', 2 => 'b' ); my %data2 = ( 1 => 'aa', 2 => 'bb' ); my $next_ref = \%data1; while (my ($key, $value) = each_kv $next_ref) { ok exists $next_ref->{$key} => 'Valid key returned'; is $next_ref->{$key}, $value => 'Correct value returned'; $next_ref = $next_ref == \%data1 ? \%data2 : \%data1; } $next_ref = \%data1; my $next_expected = 0; while (my $pair = each_pair $next_ref) { ok exists $next_ref->{$pair->key} => 'Valid key returned'; is $next_ref->{$pair->key}, $pair->value => 'Correct value returned'; $next_ref = $next_ref == \%data1 ? \%data2 : \%data1; } for my $next_ref (\%data1, \%data2) { for my $pair (pairs %{$next_ref}) { ok exists $next_ref->{$pair->key} => 'Valid key returned'; is $next_ref->{$pair->key}, $pair->value => 'Correct value returned'; } } Var-Pairs-0.004001/t/hash.t000644 000765 000024 00000000616 12200735652 015516 0ustar00damianstaff000000 000000 use 5.014; use strict; no if $] >= 5.018, warnings => "experimental::smartmatch"; use Test::More tests => 13; use Var::Pairs; my %data; @data{1..6} = ('a'..'f'); for my $next (pairs %data) { ok $next->key ~~ %data => 'key method correct'; ok $next->value eq $data{$next->key} => 'value method correct'; delete $data{$next->key}; } ok !keys %data => 'Iterated all'; Var-Pairs-0.004001/t/hash_while.t000644 000765 000024 00000000633 13273755056 016720 0ustar00damianstaff000000 000000 use 5.014; no if $] >= 5.018, warnings => "experimental::smartmatch"; use strict; use Test::More tests => 13; use Var::Pairs; my %data; @data{1..6} = ('a'..'f'); while (my $next = each_pair %data) { ok $next->key ~~ %data => 'key method correct'; ok $next->value eq $data{$next->key} => 'value method correct'; delete $data{$next->key}; } ok !keys %data => 'Iterated all'; Var-Pairs-0.004001/t/hash_while_kv.t000644 000765 000024 00000000640 12320016626 017377 0ustar00damianstaff000000 000000 use 5.014; no if $] >= 5.018, warnings => "experimental::smartmatch"; use strict; use Test::More tests => 13; use Var::Pairs; my %data; @data{1..6} = ('a'..'f'); while (my $next = each_pair %data) { my ($key, $value) = $next->kv; ok $key ~~ %data => 'key method correct'; ok $value eq $data{$key} => 'value method correct'; delete $data{$key}; } ok !keys %data => 'Iterated all'; Var-Pairs-0.004001/t/hashref.t000644 000765 000024 00000000751 12755734764 016235 0ustar00damianstaff000000 000000 use 5.014; no if $] >= 5.018, warnings => "experimental::smartmatch"; use strict; use Test::More tests => 13; use Var::Pairs; my $data_ref = {}; @{$data_ref}{1..6} = ('a'..'f'); my @keys = keys %{$data_ref}; for my $next (pairs $data_ref) { ok $next->key ~~ $data_ref => 'key method correct'; ok $next->value eq $data_ref->{$next->key} => 'value method correct'; delete $data_ref->{$next->key}; } ok !keys %{$data_ref} => 'Iterated all'; Var-Pairs-0.004001/t/kv.t000644 000765 000024 00000001630 11776217276 015226 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 5; use Var::Pairs; # What each data type is supposed to expand to... my $scalar = 'scalar value'; my $expected_scalar = [ 'scalar' => $scalar ]; my $ref = [-10..-1]; my $expected_ref = [ 'ref' => $ref ]; my @array = 1..10; my $expected_array = [ 'array' => \@array ]; my %hash; @hash{1..6} = ('a'..'f'); my $expected_hash = [ 'hash' => \%hash ]; # Do single args expand correctly??? is_deeply [to_kv($scalar)], $expected_scalar => 'to_kv $scalar'; is_deeply [to_kv($ref)], $expected_ref => 'to_kv $ref'; is_deeply [to_kv(@array)], $expected_array => 'to_kv @array'; is_deeply [to_kv(%hash)], $expected_hash => 'to_kv %hash'; # Do multiple args expand correctly??? is_deeply [to_kv $scalar, @array, %hash ], [@$expected_scalar, @$expected_array, @$expected_hash] => 'to_kv $scalar, @array, %hash'; Var-Pairs-0.004001/t/kvs.t000644 000765 000024 00000000542 12123250756 015375 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 12; use Var::Pairs; my @data = 'a'..'f'; my %data = kvs @data; for my $index (0..$#data) { is $data[$index], $data{$index} => "kv'd index $index correctly"; } while (1) { my ($index, $value) = each_kv @data or last; is $data[$index], $value => "each_kv'd index $index correctly"; } Var-Pairs-0.004001/t/lvalue.t000644 000765 000024 00000000607 11757521102 016062 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 2; use Var::Pairs; my @data = 'a'..'f'; for my $next (pairs @data) { $next->value = uc $next->value; } is_deeply \@data, ['A'..'F'] => 'Lvalue array ->value'; my %data; @data{1..6} = ('a'..'f'); for my $next (pairs %data) { $next->value .= 'z'; } is_deeply [sort values %data], [qw(az bz cz dz ez fz)] => 'Lvalue hash ->value'; Var-Pairs-0.004001/t/nested.t000644 000765 000024 00000000507 11776401322 016055 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 1; use Var::Pairs; my @data = 'a'..'f'; while (my $next_outer = each_pair @data) { while (my $next_inner = each_pair @data) { state $count = 0; $count++; END { ok $count == @data * @data => 'correct number of iterations'; } } } Var-Pairs-0.004001/t/nested_kv.t000644 000765 000024 00000000520 11776401330 016547 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 1; use Var::Pairs; my @data = 'a'..'f'; while (my ($next_outer) = each_kv @data) { while (my ($next_inner) = each_kv @data) { state $count = 0; $count++; END { cmp_ok $count, '==', @data * @data => "correct number of iterations"; } } } Var-Pairs-0.004001/t/nexted_kv_same_statement.t000644 000765 000024 00000000715 12200735522 021647 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More; use Var::Pairs; my @data = 'a'..'f'; plan tests => 1 + 2 * @data; my ($iter1, $iter2); while (my ($key1, $val1) = each_kv(@data) and my ($key2, $val2) = each_kv(@data)) { state $count = 0; $count++; is $key1, $key2 => "Iterated key in parallel ($key1)"; is $val1, $val2 => "Iterated value in parallel ($val1)"; END { cmp_ok $count, '==', @data => "correct number of iterations"; } } Var-Pairs-0.004001/t/one_liner.t000644 000765 000024 00000001465 12200736245 016547 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 3; use Var::Pairs; { my @results; my @data = 'a'..'f'; for my $next1 (pairs @data) { for my $next2 (pairs @data) { push @results, $next1->value . $next2->value; }} is_deeply \@results, [grep {/^[a-f][a-f]$/} 'aa'..'ff'] => 'nested one-liner'; } { my @results; my @data = 'a'..'f'; for my $next1 (pairs @data, pairs @data) { push @results, $next1->value; } is_deeply \@results, ['a'..'f','a'..'f'] => 'repeated pairs'; } { my @data = 'a'..'f'; while (my $next_outer = each_pair @data) { while (my $next_inner = each_pair @data) { state $count = 0; $count++; END { ok $count == @data * @data => 'correct number of iterations'; } }} } Var-Pairs-0.004001/t/to_pair.t000644 000765 000024 00000002253 11776221626 016237 0ustar00damianstaff000000 000000 use 5.014; use strict; use Test::More tests => 15; use Var::Pairs; # What each data type is supposed to expand to... my $scalar = 'scalar value'; my $ref = [-10..-1]; my @array = 1..10; my %hash; @hash{1..6} = ('a'..'f'); # Do single args expand correctly??? is +(to_pair($scalar))[0]->key, 'scalar' => 'to_pair $scalar key'; is +(to_pair($ref))[0]->key, 'ref' => 'to_pair $ref key'; is +(to_pair(@array))[0]->key, 'array' => 'to_pair @array key'; is +(to_pair(%hash))[0]->key, 'hash' => 'to_pair %hash key'; is +(to_pair($scalar))[0]->value, $scalar => 'to_pair $scalar value'; is +(to_pair($ref))[0]->value, $ref => 'to_pair $ref value'; is +(to_pair(@array))[0]->value, \@array => 'to_pair @array value'; is +(to_pair(%hash))[0]->value, \%hash => 'to_pair %hash value'; # Do multiple args expand correctly??? my @list = to_pair $scalar, @array, %hash; is scalar(@list), 3 => 'Correct number of args'; is $list[0]->key, 'scalar' => 'to_pair list keys'; is $list[1]->key, 'array'; is $list[2]->key, 'hash'; is $list[0]->value, $scalar => 'to_pair list values'; is $list[1]->value, \@array; is $list[2]->value, \%hash; Var-Pairs-0.004001/lib/Var/000755 000765 000024 00000000000 13274615570 015446 5ustar00damianstaff000000 000000 Var-Pairs-0.004001/lib/Var/Pairs/000755 000765 000024 00000000000 13274615570 016524 5ustar00damianstaff000000 000000 Var-Pairs-0.004001/lib/Var/Pairs.pm000644 000765 000024 00000065311 13274615566 017075 0ustar00damianstaff000000 000000 package Var::Pairs; use 5.014; our $VERSION = '0.004001'; 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'; } 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; # 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__ =head1 NAME Var::Pairs - OO iterators and pair constructors for variables =head1 VERSION This document describes Var::Pairs version 0.004001 =head1 SYNOPSIS use Var::Pairs; # pairs() lists all OO pairs from arrays and hashes... for my $next (pairs @array) { say $next->index, ' has the value ', $next->value; } # each_pair() iterates OO pairs from arrays and hashes... while (my $next = each_pair %hash) { say $next->key, ' had the value ', $next->value; $next->value++; } # to_kv() converts vars into var_name => var_value pairs... Sub::Install::install_sub({to_kv $code, $from, $into}); # invert() reverses a one-to-many mapping correctly... my %reverse_mapping = invert %mapping; my %reverse_lookup = invert @data; =head1 DESCRIPTION This module exports a small number of subroutines that add some Perl 6 conveniences to Perl 5. Specifically, the module exports several subroutines that simplify interactions with key/value pairs in hashes and arrays. =head1 INTERFACE =head2 Array and hash iterators =over =item C =item C =item C In list context, C returns a list of "pair" objects, each of which contains one key/index and value from the argument. In scalar and void contexts, C throws an exception. The typical list usage is: for my $pair (pairs %container) { # ...do something with $pair } The intent is to provide a safe and reliable replacement for the built-in C function; specifically, a replacement that can be used in C loops. =back =over =item C =item C =item C In list context, C returns a list of alternating keys and values. That is C flattens the hash to C<(I, I, I, I...)> and C flattens the array to C<(I, I, I, I...)>. In scalar and void contexts, C throws an exception. The most typical use is to populate a hash from an array: my %hash = kvs @array; # does the same as: my %hash; @hash{0..$#array} = @array; =back =over =item C =item C =item C =item C In all contexts, C returns a single "pair" object, containing the key/index and value of the next element in the argument. A separate internal iterator is created for each call to C, so multiple calls to C on the same container variable can be nested without interacting with each other (i.e. unlike multiple calls to C). When the iterator is exhausted, the next call to C returns C or an empty list (depending on context), and resets the iterator. The iterator is also reset when execution leaves the block in which C is called. This means, for example, that C-ing out of the middle of an iterated loop does the right thing (by resetting the iterator). The typical usage is: while (my $pair = each_pair %container) { # ...do something with $pair->key and $pair->value } Note, however, that using C in a C loop is the preferred idiom: for my $pair (pairs %container) { # ...do something with $pair->key and $pair->value } The C subroutine can also be passed a reference to a subroutine, in which case that subroutine is used directly as the iterator. When iterated, this iterator subroutine is called in list context and is expected to return a single value on each call (i.e. the next value to be iterated), or else an empty list when the iterator is exhausted. For example: # Calling this sub returns a reference to an anonymous iterator sub... sub count_down { my ($from, $to) = @_; return sub { return () if $from < $to; # End of iterator return $from--; # Next iterated value } } # Build a 10-->1 countdown and iterate it... while (my $next = each_pair count_down(10, 1)) { say $next->value; } =back =over =item C =item C =item C =item C This subroutine is very similar to C, except that in list contexts, returns a list of two elements: the key/index and the value of the next element in the argument. In scalar contexts, just the next key is returned. As with C, a separate internal iterator is created for each call to C, so multiple calls to C on the same container variable can be nested without interacting with each other (i.e. unlike multiple calls to C). When the iterator is exhausted, the next call to C returns C in scalar context or an empty list in list context, and resets the iterator. The iterator is also reset when execution leaves the block in which C is called. The typical list usage is: while (my ($key1, $val1) = each_kv %container) { while (my ($key2, $val2) = each_kv %container) { # ...do something with the two keys and two values } } The typical scalar usage is: while (my $key1 = each_kv %container) { while (my $key2 = each_kv %container) { # ...do something with the two keys } } In other words, C is a drop-in replacement for Perl's built-in C, with two exceptions: one an advantage, the other a limitation. The advantage is that you can nest C iterations over the same variable without shooting yourself in the foot. The limitation is that, unlike C, C does not reset when you call the C function on the hash you're iterating. =back =over =item C =item C =item C =item C The C subroutine works exactly like C, except that in all contexts it just returns the value being iterated, not the key or key/value combination. For example: # Build a 10-->1 countdown and iterate it... while (my ($next) = each_value count_down(10, -10)) { say $next; } while (my $value1 = each_value %container) { while (my $value2 = each_value %container) { # ...do something with the two values } } Note that, if your iterator can return a false value, such as 0 from the C iterator in the previous example, then you should call C in list context (as in the C example) so that the false value does not prematurely terminate the C loop. =back =over =item C<< %hash->pairs >> =item C<< @array->pairs >> =item C<< $hash_or_array_ref->pairs >> =item C<< %hash->kvs >> =item C<< @array->kvs >> =item C<< $hash_or_array_ref->kvs >> =item C<< %hash->each_pair >> =item C<< @array->each_pair >> =item C<< $hash_or_array_ref->each_pair >> =item C<< %hash->each_kv >> =item C<< @array->each_kv >> =item C<< $hash_or_array_ref->each_kv >> =item C<< %hash->each_value >> =item C<< @array->each_value >> =item C<< $hash_or_array_ref->each_value >> If you have the C module installed, you can use this OO syntax as well. Apart from their call syntax, these OO forms are exactly the same as the subroutine-based interface described above. =back =head2 Pairs =over =item C<< $pair->key >> Returns a copy of the key of the pair, if the pair was derived from a hash. Returns a copy of the index of the pair, if the pair was derived from an array. =item C<< $pair->index >> Nothing but a synonym for C<< $pair->key >>. Use whichever suits your purpose, your program, or your predilections. =item C<< $pair->value >> Returns the value of the pair, as an lvalue. That is: for my $item (pairs %items) { say $item->value if $item->key =~ /\d/; } will print the value of every entry in the C<%items> hash whose key includes a digit. And: for my $item (pairs %items) { $item->value++; if $item->key =~ /^Q/; } will increment each value in the C<%items> hash whose key starts with 'Q'. =item C<< $pair->kv >> Returns a two-element list containing copies of the key and the value of the pair. That is: for my $item (pairs %items) { my ($k, $v) = $item->kv; say $v if $k =~ /\d/; } will print the value of every entry in the C<%items> hash whose key includes a digit. =item C<< "$pair" >> When used as a string, a pair is converted to a suitable representation for a pair, namely: C<< "I => I" >> =item C<< 0 + $pair >> Pairs cannot be used as numbers: an exception is thrown. =item C<< if ($pair) {...} >> When a pair is used as a boolean, it is always true. =back =head2 Named pair constructors =over =item C<< to_pair $scalar, @array, %hash, $etc >> The C subroutine takes one or more variables and converts each of them to a single Pair object. The Pair's key is the name of the variable (minus its leading sigil), and the value is the value of the variable (if it's a scalar) or a reference to the variable (if it's an array or hash). That is: to_pair $scalar, @array, %hash, $etc is equivalent to: Pair->new( scalar => $scalar ), Pair->new( array => \@array ), Pair->new( hash => \%hash ), Pair->new( etc => $etc ) This is especially useful for generating modern sets of named arguments for other subroutines. For example: Sub::Install::install_sub(to_pair $code, $from, $into); instead of: Sub::Install::install_sub( Pair->new(code => $code), Pair->new(from => $from), Pair->new(into => $into) ); =item C<< to_kv $scalar, @array, %hash, $etc >> The C subroutine takes one or more variables and converts each of them to a I C<< => >> I sequence (i.e. a two-element list, rather than a Pair object). As with C, the key is the name of the variable (minus its leading sigil), and the value is the value of the variable (if it's a scalar) or a reference to the variable (if it's an array or hash). That is: to_kv $scalar, @array, %hash, $etc is equivalent to: scalar => $scalar, array => \@array, hash => \%hash, etc => $etc This is especially useful for generating traditional sets of named arguments for other subroutines. For example: Sub::Install::install_sub({to_kv $code, $from, $into}); instead of: Sub::Install::install_sub({code => $code, from => $from, into => $into}); =back =head2 Array and hash inverters =over =item C<< invert %hash >> =item C<< invert @array >> =item C<< invert $hash_or_array_ref >> The C subroutine takes a single hash or array (or a reference to either) and returns a list of alternating keys and value, where each key is a value from the original variable and each corresponding value is a reference to an array containing the original key(s). This list is typically used to initialize a second hash, which can then be used as a reverse mapping. In other words: my %hash = ( a => 1, b => 2, c => 1, d => 1, e => 2, f => 3 ); my %inversion = invert %hash; is equivalent to: my %inversion = ( 1 => ['a', 'c', 'd'], 2 => ['b', 'e'], 3 => ['f'], ); C correctly handles the many-to-many case where some of the values in the original are array references. For example: my %hash = ( a => [1,2], b => 2, c => [1,3], d => 1, e => [3,2], f => 3 ); my %inversion = invert %hash; is equivalent to: my %inversion = ( 1 => ['a', 'c', 'd'], 2 => ['a', 'b', 'e'], 3 => ['c', 'e', 'f'], ); =item C<< invert_pairs %hash >> =item C<< invert_pairs @array >> =item C<< invert_pairs $hash_or_array_ref >> C acts exactly like C, except that it returns a list of Pair objects (like C does). This is not useful for initializing other hashes, but is handy for debugging a reverse mapping: say for invert_pairs %hash; =item C<< %hash->invert >> or C<< %hash->invert_pairs >> =item C<< @array->invert >> or C<< @array->invert_pairs >> =item C<< $hash_or_array_ref->invert >> or C<< $hash_or_array_ref->invert_pairs >> If you have the C module installed, you can use this OO syntax as well. Apart from their call syntax, these OO forms are exactly the same as the subroutine-based interfaces described above. =back =head1 DIAGNOSTICS =over =item C<< Argument to %s must be hash or array (not %s) >> Except for C and C, all of the subroutines exported by this module only operate on hashes, arrays, or references to hashes or arrays. Asking for the "pairs" insidde a scalar, typeglob, or other entity is meaningless; they're simply not structured as collections of keyed values. =item C<< Useless use of pairs() in void context >> =item C<< Useless use of kvs() in void context >> =item C<< Useless use of invert() in void context >> None of these subroutines has any side-effects, so calling them in void context is a waste of time. =item C<< Invalid call to pairs() in scalar context >> =item C<< Invalid call to kvs() in scalar context >> =item C<< Invalid call to invert() in scalar context >> All these subroutines return a list, so in scalar context you just get a count (which there are cheaper and easier ways to obtain). The most common case where this error is reported is when C or C is used in a C loop, instead of a C loop. Either change the type of loop, or else use C or C instead. =item C<< Can't convert Pair(%s => %s) to a number >> You attempted to use one of the pair objects returned by C as a number, but the module has no idea how to do that. You probably need to use C<< $pair->index >> or C<< $pair->value >> instead. =back =head1 CONFIGURATION AND ENVIRONMENT Var::Pairs requires no configuration files or environment variables. =head1 DEPENDENCIES The module requires Perl 5.014 and the following modules: =over =item Perl 5.14 or later =item Devel::Callsite =item Data::Alias (under Perl 5.20 and earlier) =item PadWalker =back To use the optional C<< $container->pairs >> syntax, you also need the C module. =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. C acts like a true one-time only iterator (in the OO sense), so there is no way to reset its iteration (i.e. the way that calling C on a hash or array, resets any C that is iterating it). If you need to reset partially iterated hashes or arrays, you will need to use some other mechanism to do so. =head1 ACKNOWLEDGEMENTS Based on a suggestion by Karl Brodowsky and inspired by several features of Perl 6. =head1 AUTHOR Damian Conway C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2012, Damian Conway C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Var-Pairs-0.004001/lib/Var/Pairs/Pair_BuiltIn.pm000644 000765 000024 00000005036 13274001556 021400 0ustar00damianstaff000000 000000 package Var::Pairs::Pair_BuiltIn; use strict; use warnings; use experimental 'refaliasing'; # Class implementing each key/value pair... # (aliasing via 5.22 built-in aliasing) package Var::Pairs::Pair { use Scalar::Util qw< looks_like_number >; use Carp; # Each pair object has two attributes... my @key_for; my @value_for; my @freed; # Accessors for the attributes (value is read/write)... sub value :lvalue { $value_for[${shift()}] } sub index { $key_for[${shift()}] } sub key { $key_for[${shift()}] } sub kv { my $self = shift; $key_for[$$self], $value_for[$$self] } # The usual inside-out constructor... sub new { my ($class, $key, $container_ref, $container_type) = @_; # Create a scalar based object... my $scalar = @key_for; my $new_obj = bless \$scalar, $class; # Initialize its attributes (value needs to be an alias to the original)... $key_for[$scalar] = $key; \$value_for[$scalar] = $container_type eq 'array' ? \$container_ref->[$key] : $container_type eq 'none' ? \$_[2] : \$container_ref->{$key}; $freed[$scalar] = 0; return $new_obj; } # Type coercions... use overload ( # As a string, a pair is just: key => value q{""} => sub { my $self = shift; my $value = $value_for[$$self]; $value = ref $value ? ref $value : looks_like_number($value) ? $value : qq{"$value"}; return "$key_for[$$self] => $value"; }, # Can't numerify a pair (make it a hanging offence)... q{0+} => sub { croak "Can't convert Pair(".shift.") to a number" }, # All pairs are true (just as in Perl 6)... q{bool} => sub { !!1 }, # Everything else as normal... fallback => 1, ); sub DESTROY { my $self = shift; # Mark current storage as reclaimable... $freed[$$self] = 1; # Reclaim everything possible... if ($freed[$#freed]) { my $free_from = $#freed; while ($free_from >= 0 && $freed[$free_from]) { $free_from--; } splice @key_for, $free_from+1; splice @value_for, $free_from+1; splice @freed, $free_from+1; } } } # Magic true value required at the end of a module... 1; Var-Pairs-0.004001/lib/Var/Pairs/Pair_DataAlias.pm000644 000765 000024 00000004777 13274004567 021675 0ustar00damianstaff000000 000000 package Var::Pairs::Pair; use warnings; # Class implementing each key/value pair... # (aliasing via Data::Alias) package Var::Pairs::Pair { use Scalar::Util qw< looks_like_number >; use Data::Alias; use Carp; # Each pair object has two attributes... my @key_for; my @value_for; my @freed; # Accessors for the attributes (value is read/write)... sub value :lvalue { $value_for[${shift()}] } sub index { $key_for[${shift()}] } sub key { $key_for[${shift()}] } sub kv { my $self = shift; $key_for[$$self], $value_for[$$self] } # The usual inside-out constructor... sub new { my ($class, $key, $container_ref, $container_type) = @_; # Create a scalar based object... my $scalar = @key_for; my $new_obj = bless \$scalar, $class; # Initialize its attributes (value needs to be an alias to the original)... $key_for[$scalar] = $key; alias $value_for[$scalar] = $container_type eq 'array' ? $container_ref->[$key] : $container_type eq 'none' ? $_[2] : $container_ref->{$key}; $freed[$scalar] = 0; return $new_obj; } # Type coercions... use overload ( # As a string, a pair is just: key => value q{""} => sub { my $self = shift; my $value = $value_for[$$self]; $value = ref $value ? ref $value : looks_like_number($value) ? $value : qq{"$value"}; return "$key_for[$$self] => $value"; }, # Can't numerify a pair (make it a hanging offence)... q{0+} => sub { croak "Can't convert Pair(".shift.") to a number" }, # All pairs are true (just as in Perl 6)... q{bool} => sub { !!1 }, # Everything else as normal... fallback => 1, ); sub DESTROY { my $self = shift; # Mark current storage as reclaimable... $freed[$$self] = 1; # Reclaim everything possible... if ($freed[$#freed]) { my $free_from = $#freed; while ($free_from >= 0 && $freed[$free_from]) { $free_from--; } splice @key_for, $free_from+1; splice @value_for, $free_from+1; splice @freed, $free_from+1; } } } # Magic true value required at the end of a module... 1;