Util-H2O
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
},
},
},
CONFIGURE_REQUIRES => {
'ExtUtils::MakeMaker' => '6.64',
},
PREREQ_PM => {
'Carp' => 0,
'Exporter' => '5.58',
'Symbol' => 0,
( $] ge '5.008009' ? (
'Hash::Util' => '0.06',
):()),
},
TEST_REQUIRES => {
'Test::More' => '1.302096',
'Scalar::Util' => 0,
},
);
sub MY::postamble {
return <<'MAKE_FRAG';
lib/Util/H2O.pm view on Meta::CPAN
# For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file
our @EXPORT = qw/ h2o /; ## no critic (ProhibitAutomaticExportation)
our @EXPORT_OK = qw/ o2h /;
BEGIN {
# lock_ref_keys wasn't available until Hash::Util 0.06 / Perl v5.8.9
# (note the following will probably also fail on the Perl v5.9 dev releases)
# uncoverable branch false
# uncoverable condition false
if ( $] ge '5.008009' ) {
require Hash::Util;
Hash::Util->import(qw/ lock_ref_keys lock_hashref /) }
else {
*lock_ref_keys = *lock_hashref = sub {
carp "this Perl is too old to lock the hash"; # uncoverable statement
}; # uncoverable statement
}
}
=head1 Description
t/Util-H2O.t view on Meta::CPAN
sub exception (&) { eval { shift->(); 1 } ? undef : ($@ || die) } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn, RequireCarping)
sub warns (&) { my @w; { local $SIG{__WARN__} = sub { push @w, shift }; shift->() } @w } ## no critic (ProhibitSubroutinePrototypes, RequireFinalReturn)
## no critic (RequireTestLabels)
diag "This is Perl $] at $^X on $^O";
BEGIN { use_ok 'Util::H2O' }
is $Util::H2O::VERSION, '0.24';
diag "If all tests pass, you can ignore the \"this Perl is too old\" warnings"
if $] lt '5.008009';
my $PACKRE = $Util::H2O::_PACKAGE_REGEX; ## no critic (ProtectPrivateVars)
{
my $hash = { foo => "bar", x => "y" };
my $o1 = h2o $hash, qw/ more keys /;
is $o1, $hash;
like blessed($o1), $PACKRE;
is $o1->foo, 'bar';
is $o1->x, 'y';
t/Util-H2O.t view on Meta::CPAN
is ref $o4->h, 'HASH';
is ref $o4->c, 'CODE';
is ref $o4->a2, 'ARRAY';
is ref $o4->a2->[0], 'HASH';
is $o4->a2->[0]{x}, 'y';
is $o4->c, $code;
}
{
my $o = h2o -recurse, { foo => { bar => "quz" } };
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { $o->{abc} = 123 };
ok exception { $o->foo->{def} = 456 };
}
my $o2 = h2o -recurse, -nolock, { foo => { bar => "quz" } };
$o2->{abc} = 123;
$o2->foo->{def} = 456;
is_deeply [sort keys %$o2], [qw/ abc foo /];
is_deeply [sort keys %{$o2->foo}], [qw/ bar def /];
}
t/Util-H2O.t view on Meta::CPAN
my $aref = [ { xyz=>'abc' }, $obj ];
my $o = h2o(-arrays, -pass=>'ref', $aref);
is 0+$o, 0+$aref;
is $o->[0]->xyz, 'abc';
is ref $o->[1], 'SomeClass';
}
# -arrays + -lock + -ro
{
my $o = h2o -arrays, -lock=>1, -ro, { abc => [ { def => 'ghi' } ] };
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { my $x = $o->{zzz} };
ok exception { my $y = $o->{abc}[0]{def}{yyy} };
}
is $o->abc->[0]->def, 'ghi';
ok exception { $o->abc(123) };
ok exception { $o->abc->[0]->def(123) };
push @{ $o->abc }, { xyz => 777 };
is $o->abc->[1]{xyz}, 777;
}
t/Util-H2O.t view on Meta::CPAN
is o2h(0), 0; # coverage
ok exception { o2h(-42) };
is o2h('--', -42), -42;
is o2h('--'), '--';
ok exception { o2h('-arrays', '--') };
}
# o2h + -lock + -ro
{
my $o = h2o -recurse, -lock=>1, -ro, { abc => { def => { ghi => 555 } } };
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { my $x = $o->{zzz} };
ok exception { my $y = $o->{abc}{def}{yyy} };
}
my $h = o2h $o;
is ref $h, 'HASH';
is ref $h->{abc}{def}, 'HASH';
$h->{zzz} = 543;
$h->{abc}{def}{ghi} = 777;
is_deeply $h, { abc => { def => { ghi => 777 } }, zzz => 543 };
}
t/Util-H2O.t view on Meta::CPAN
is ref $o6->a->d, 'CODE';
is $o6->f, 'g';
}
{
my $o = h2o -meth, { x=>111, y=>sub{222} };
is $o->x, 111;
is $o->y, 222;
is_deeply [sort keys %$o], [qw/ x /];
is $o->{x}, 111;
SKIP: {
skip "Won't work on old Perls", 1 if $] lt '5.008009';
ok exception { my $x = $o->{y} };
}
}
{
my $o = h2o -meth, { x=>111, y=>sub{222} }, qw/y/;
is $o->x, 111;
is $o->y, 222;
is_deeply [sort keys %$o], [qw/ x /];
$o->{y} = 333;
is_deeply $o, { x=>111, y=>333 };
t/Util-H2O.t view on Meta::CPAN
{
my $n = h2o -class=>'Quz', -new, {}, qw/ abc /;
isa_ok $n, 'Quz';
my $n2 = new_ok 'Quz';
is $n2->abc, undef;
my $n3 = $n2->new(abc=>444);
is $n3->abc, 444;
like exception { Quz->new(abc=>4,5) }, qr/\bOdd\b/;
like exception { Quz->new(def=>4) }, qr/\bUnknown argument\b/i;
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { my $x = $n->{new} };
ok exception { my $x = $n->{DESTROY} };
}
}
{
my $o = h2o -meth, -new, { x=>111, y=>sub{222} }, qw/y/;
my $n = $o->new( x=>333, y=>444 );
is_deeply $n, { x=>333, y=>444 };
is $n->y, 222;
is $n->{y}, 444;
t/Util-H2O.t view on Meta::CPAN
use Util::H2O;
h2o -classify, { hello=>sub{"World!"} }, qw/abc/;
sub test { return "<".shift->abc.">" }
}
my $o = new_ok 'Yet::Another', [ abc=>"def" ];
is $o->hello, "World!";
is $o->test, "<def>";
ok exists &Yet::Another::h2o;
}
SKIP: {
skip "Won't work on really old Perls", 2 if $] lt '5.008';
my @w = warns {
my $x = h2o -clean=>1, -classify, {};
isa_ok $x, 'main';
};
is grep({/\brefusing to delete package\b/i} @w), 1;
}
# -lock / -nolock
{
my $o = h2o { foo=>123 }, qw/ bar /;
is $o->{foo}, 123;
is $o->{bar}, undef;
is_deeply [sort keys %$o], [qw/ foo /];
$o->{bar} = 456;
is $o->{bar}, 456;
is_deeply [sort keys %$o], [qw/ bar foo /];
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { my $x = $o->{quz} };
ok exception { $o->{quz} = 789 };
}
}
{
my $o = h2o -lock=>1, { foo=>123 }, qw/ bar /;
SKIP: {
skip "Won't work on old Perls", 2 if $] lt '5.008009';
ok exception { my $x = $o->{quz} };
ok exception { $o->{quz} = 789 };
}
}
{
my $o = h2o -lock=>0, { foo=>123 }, qw/ bar /;
is $o->{foo}, 123;
is $o->{bar}, undef;
is_deeply [sort keys %$o], [qw/ foo /];
$o->{bar} = 456;
t/Util-H2O.t view on Meta::CPAN
is $o->{bar}, 456;
is_deeply [sort keys %$o], [qw/ bar foo /];
$o->{quz} = 789;
is $o->{quz}, 789;
is_deeply [sort keys %$o], [qw/ bar foo quz /];
ok exception { my $x = $o->quz };
}
{
h2o -class=>'Baz', -new, {}, qw/ abc /;
my $n = Baz->new(abc=>123);
if ($] lt '5.008009') {
$n->{def} = 456;
is_deeply [sort keys %$n], [qw/ abc def /];
pass 'dummy'; # so the number of tests still fits
}
else {
ok exception { $n->{def} = 456 };
is_deeply [sort keys %$n], [qw/ abc /];
}
}
{
h2o -class=>'Baz2', -new, -nolock, {}, qw/ abc /;
my $n = Baz2->new(abc=>123);
$n->{def} = 456;
is_deeply [sort keys %$n], [qw/ abc def /];
}
# -ro
SKIP: {
skip "Won't work on old Perls", 36 if $] lt '5.008009';
my $o = h2o -ro, { foo=>123, bar=>undef };
is $o->foo, 123;
is $o->bar, undef;
ok exception { $o->foo(456) };
ok exception { $o->bar(789) };
ok exception { $o->{foo} = 456 };
ok exception { $o->{bar} = 789 };
ok exception { $o->{quz} = 111 };
is $o->foo, 123;
is $o->bar, undef;
t/Util-H2O.t view on Meta::CPAN
}
my @redef_warns = warns {
h2o { abc => "def" }, qw/ abc /;
h2o {}, qw/ abc abc /;
};
# There were spurious CPAN Testers failures here, see xt/redef.t for details
ok !grep { /redefined/i } @redef_warns or diag explain \@redef_warns; ## no critic (ProhibitMixedBooleanOperators)
SKIP: {
skip "Tests only for old Perls", 4 if $] ge '5.008009';
my @w = warns {
my $o1 = h2o {};
$o1->{bar} = 456;
is_deeply [%$o1], [ bar=>456 ];
my $o2 = h2o -ro, { foo=>123 };
$o2->{foo} = 456;
ok exception { $o2->foo(789) };
is_deeply [%$o2], [ foo=>456 ];
};
is grep({ /\btoo old\b/i } @w), 2;
t/Util-H2O.t view on Meta::CPAN
ok exception { h2o(-isa=>{}) };
ok exception { h2o -pass=>undef, {} };
ok exception { h2o -pass=>[], {} };
ok exception { h2o -pass=>"foo", {} };
ok exception { o2h(-foobar) };
ok exception { o2h(-arrays) };
ok exception { o2h(undef, undef) };
ok exception { o2h({x=>1},{y=>2}) };
diag "If all tests pass, you can ignore the \"this Perl is too old\" warnings"
if $] lt '5.008009';
done_testing;
( run in 2.029 seconds using v1.01-cache-2.11-cpan-cc502c75498 )