File Coverage

blib/lib/Worlogog/Restart.pm

Criterion	Covered	Total	%
statement	59	61	96.7
branch	13	14	92.8
condition	1	3	33.3
subroutine	15	15	100.0
pod	5	5	100.0
total	93	98	94.9

package Worlogog::Restart;

use warnings;
use strict;

our $VERSION = '0.02';

use Carp qw(croak);
use Scope::OnExit::Wrap qw(on_scope_exit);
use Return::MultiLevel qw(with_return);

use parent 'Exporter::Tiny';
our @EXPORT_OK = qw(
    case
    bind
    invoke
    find
    compute
);

our @restarts;

sub bind (&$) {
    my ($body, $handlers) = @_;
    my $limit = @restarts;
    my $guard = on_scope_exit { splice @restarts, $limit };
    push @restarts, \%$handlers;
    $body->()
}

sub case (&$) {
    my ($body, $handlers) = @_;
    my $limit = @restarts;
    my $guard = on_scope_exit { splice @restarts, $limit };
    my $wantlist = wantarray;
    my @v = with_return {
        my ($return) = @_;
        push @restarts, {
            map {
                my $v = $handlers->{$_};
                $_ => sub { $return->($v, @_) }
            } keys %$handlers
        };
        unless (defined $wantlist) {
            $body->();
            return;
        }
        undef, $wantlist ? $body->() : scalar $body->()
    };
    if (my $f = shift @v) {
        return $f->(@v);
    }
    $wantlist ? @v : $v[0]
}

sub _find {
    my ($k) = @_;
    for my $rs (reverse @restarts) {
        my $v = $rs->{$k};
        return $v if $v;
    }
    undef
}

sub invoke {
    my $proto = shift;
    my $code = ref $proto ? $proto->code : _find($proto) || croak qq{No restart named "$proto" is active};
    $code->(@_)
}

sub find {
    my ($name) = @_;
    my $code = _find($name) or return undef;
    require Worlogog::Restart::Restart;
    Worlogog::Restart::Restart->new(
        name => $name,
        code => $code,
    )
}

sub compute {
    my @r;
    for my $rs (reverse @restarts) {
        for my $k (sort keys %$rs) {
            my $v = $rs->{$k};
            require Worlogog::Restart::Restart;
            push @r, Worlogog::Restart::Restart->new(
                name => $k,
                code => $v,
            );
        }
    }
    @r
}

'ok'

__END__