t/coderefs.t - metacpan.org

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use Test::Exception;

my $preloaded;
BEGIN { $preloaded = !!$INC{'KiokuDB/Test/Employee.pm'} }

use KiokuDB;

my $dir = KiokuDB->connect("hash");

{

    package KiokuDB_Test_WithCodeRef;
    use KiokuDB::Class;

    has coderef => (
        is       => 'rw',
        isa      => 'CodeRef',
        required => 1,
    );

    sub apply { shift->coderef->(@_) }
}

sub obj (&) { KiokuDB_Test_WithCodeRef->new( coderef => $_[0] ) }

{
    my $id;

    {
        my $obj = obj { 4 + $_[0] };

        my $s = $dir->new_scope;

        lives_ok { $id = $dir->store($obj) } "store object with coderef";
    }

    $dir->live_objects->clear; # non closure coderefs live forever

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        $id and my $obj = $dir->lookup($id);

        isa_ok $obj, 'KiokuDB_Test_WithCodeRef';
        is eval { $obj->coderef->(38) }, 42, "apply coderef",
    }
}

{
    $dir->live_objects->clear;

    {
        my $s = $dir->new_scope;

        my ( $x, @x, %x );

        # these tests cause leaks in 5.8 if they use Test::Exception

        eval { $dir->store( sv  => sub { $x++ } ) };
        ok( !$@, "SV" );
        eval { $dir->store( av  => sub { $x[0]++ } ) };
        ok( !$@, "AV" );
        eval { $dir->store( hv  => sub { $x{foo}++ } ) };
        ok( !$@, "HV" );
        eval { $dir->store( all => sub { $x++; $x[0]++; $x{foo}++ } ) };
        ok( !$@, "SV, AV, HV" );
    }

    {
        foreach my $id ( qw(sv av hv all) ) {
            is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

            my $s = $dir->new_scope;

            my $sub;
            lives_ok { $sub = $dir->lookup($id) } "load closure $id";

            ok( $sub, "thawed closure" );

            is( eval { $sub->() }, 0, "first invocation" );
            is( eval { $sub->() }, 1, "second invocation" );
        }
    }
}

{
    $dir->live_objects->clear;

    sub generate_counter {
        my $i = shift;

        return obj {
            return ++$i;
        }
    }

    my $id;

    {
        my $obj = generate_counter(0);

        # kick the counter once with first object.
        is( $obj->coderef->(), 1, "apply closure before storing" );

        my $s = $dir->new_scope;
        lives_ok { $id = $dir->store($obj) } "store object with closure";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;
        $id and my $obj = $dir->lookup($id);

        is eval { $obj->apply }, 2, "closure variable thawed";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;
        $id and my $obj = $dir->lookup($id);

        is eval { $obj->apply }, 2, "closure variable update not stored without call to update";

        ok( $dir->object_to_id($obj->coderef), "code ref has an ID" );

        eval { $dir->deep_update($obj->coderef) };
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;
        $id and my $obj = $dir->lookup($id);

        is eval { $obj->apply }, 3, "closure variable updated";
    }
}

sub closure_pair {
    my $i = shift;
    return (
        sub {
            return ++$i;
        },
        sub { $i },
    );
}

{
    my @ids;

    {
        my ( $count, $peek ) = map { &obj($_) } closure_pair(0);

        is( $peek->apply, 0, "peek" );
        $count->apply;
        is( $peek->apply, 1, "peek" );

        my $s = $dir->new_scope;
        lives_ok { @ids = $dir->store( $count, $peek ) } "store pair of closures";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my ( $count, $peek ) = $dir->lookup(@ids);

        ok( $count, "count thawed" );
        ok( $peek, "peek thawed" );

        is eval { $peek->apply }, 1, "closure sharing";;
        is eval { $count->apply }, 2, "closure sharing";
        is eval { $peek->apply }, 2, "closure sharing thawed";
    }
}

{
    my @ids;

    {
        my ( $count, $peek ) = closure_pair(0);

        is( $peek->(), 0, "peek" );
        $count->();
        is( $peek->(), 1, "peek" );

        my $s = $dir->new_scope;
        lives_ok { @ids = $dir->store( $count, $peek ) } "store pair of closures";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my ( $count, $peek ) = $dir->lookup(@ids);

        ok( $count, "count thawed" );
        ok( $peek, "peek thawed" );

        is eval { $peek->() }, 1, "closure sharing";;
        is eval { $count->() }, 2, "closure sharing";
        is eval { $peek->() }, 2, "closure sharing thawed";

        $dir->deep_update($count);
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my ( $count, $peek ) = $dir->lookup(@ids);

        is eval { $peek->() }, 2, "closure sharing thawed after deep update from other closure";
    }
}

{
    my @ids;

    {
        my ( $count, $peek ) = closure_pair(0);

        is( $peek->(), 0, "peek" );
        $count->();
        is( $peek->(), 1, "peek" );

        my $s = $dir->new_scope;
        lives_ok { $ids[0] = $dir->store($count) } "store count closure";
        lives_ok { $ids[1] = $dir->store($peek ) } "store peek closures";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my ( $count, $peek ) = $dir->lookup(@ids);

        ok( $count, "count thawed" );
        ok( $peek, "peek thawed" );

        is eval { $peek->() }, 1, "closure sharing";;
        is eval { $count->() }, 2, "closure sharing";
        is eval { $peek->() }, 2, "closure sharing thawed";

        $dir->deep_update($count);
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my ( $count, $peek ) = $dir->lookup(@ids);

        is eval { $peek->() }, 2, "closure sharing thawed after deep update from other closure";
    }
}

{
    my @ids;

    {
        my ( $count, $peek ) = closure_pair(0);

        is( $peek->(), 0, "peek" );
        $count->();
        is( $peek->(), 1, "peek" );

        my $s = $dir->new_scope;
        lives_ok { @ids = $dir->store( $count, $peek ) } "store pair of closures";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my $peek = $dir->lookup($ids[1]);

        ok( $peek, "peek thawed" );

        is eval { $peek->() }, 1, "closure sharing";;
    }

    {
        my $s = $dir->new_scope;

        my $count = $dir->lookup($ids[0]);

        ok( $count, "count thawed" );

        is eval { $count->() }, 2, "closure sharing";

        $dir->deep_update($count);
    }

    {
        my $s = $dir->new_scope;

        my $peek = $dir->lookup($ids[1]);

        ok( $peek, "peek thawed" );

        is eval { $peek->() }, 2, "closure sharing after disjoint update";
    }
}

{
    my @ids;

    {
        my ( $count, $peek ) = closure_pair(0);

        is( $peek->(), 0, "peek" );
        $count->();
        is( $peek->(), 1, "peek" );

        my $s = $dir->new_scope;
        lives_ok { @ids = $dir->store( $count, $peek ) } "store pair of closures";
    }

    is_deeply( [ $dir->live_objects->live_objects ], [], "no live objects" );

    {
        my $s = $dir->new_scope;

        my $peek = $dir->lookup($ids[1]);

        ok( $peek, "peek thawed" );

        is eval { $peek->() }, 1, "closure sharing";;

        my $count = $dir->lookup($ids[0]);

        ok( $count, "count thawed" );

        is eval { $count->() }, 2, "closure sharing";

        is eval { $peek->() }, 2, "closure sharing after disjoint update (both values live)";
    }
}

{
    my ( $set_id, $get_id );

    {
        my %names;

        ( $set_id, $get_id ) = $dir->txn_do( scope => 1, body => sub {
            $dir->insert( sub { $names{$_[0]} = $_[1] }, sub { $names{$_[0]} } );
        });

        is_deeply( [ $dir->live_objects->live_objects ], [ \%names ], "names is live" );

        {
            my $s = $dir->new_scope;

            my $set = $dir->lookup($set_id);

            ok( $set, "got set" );

            $set->( foo => 42 );

            is_deeply( \%names, { foo => 42 }, "still live closure variable updated" );

            $dir->update(\%names);
        }
    }

    {
        my $s = $dir->new_scope;

        my $get = $dir->lookup($get_id);

        is( $get->("foo"), 42, "names updated" );
    }
}

sub blah { 42 }

{
    my $blah_id= $dir->txn_do( scope => 1, body => sub {
        $dir->insert(\&blah)
    });

    $dir->live_objects->clear;

    {
        my $s = $dir->new_scope;

        my $blah = $dir->lookup($blah_id);

        ok( $blah, "got named sub" );

        is( $blah->(), 42, "correct value" );

        is( $blah, \&blah, "right refaddr" );
    }

    $dir->live_objects->clear;
}

{
    $dir->txn_do( scope => 1, body => sub {
        $dir->backend->insert(
            KiokuDB::Entry->new(
                id => "lalala",
                data => {
                    package => "KiokuDB::Test::Employee",
                    name    => "lalala",
                },
                class => "CODE",
            ),
        );
    });

    {
        my $s = $dir->new_scope;

        SKIP: {
            skip "doesn't work when preloading", 1 if $preloaded;
            ok( !exists($INC{"KiokuDB/Test/Employee.pm"}), "Employee.pm not loaded" );
        }

        my $sub = $dir->lookup("lalala");

        ok( $sub, "loaded sub" );

        ok( $INC{"KiokuDB/Test/Employee.pm"}, "Employee.pm loaded" );

        is( $sub, \&KiokuDB::Test::Employee::lalala, "right refaddr" );
        is( $sub->(), 333, "right value" );
    }

    $dir->live_objects->clear;
}

{
    my $sub_id = $dir->txn_do( scope => 1, body => sub {
        $dir->insert(\&KiokuDB::Test::Employee::company);
    });

    my $entry = $dir->live_objects->id_to_entry($sub_id);

    ok( !exists($entry->data->{file}), "Moose accessor detected" );
    is_deeply( $entry->data, { package => "KiokuDB::Test::Employee", name => "company" }, "FQ reference only" );

    $dir->live_objects->clear;
}


{
    my $sub_id = $dir->txn_do( scope => 1, body => sub {
        $dir->insert(\&Scalar::Util::weaken);
    });

    my $entry = $dir->live_objects->id_to_entry($sub_id);

    ok( !exists($entry->data->{file}), "XSUB detected" );
    is_deeply( $entry->data, { package => "Scalar::Util", name => "weaken" }, "FQ reference only" );

    $dir->live_objects->clear;
}


done_testing;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)