File Coverage

blib/lib/Worlogog/Incident.pm

Criterion	Covered	Total	%
statement	63	70	90.0
branch	10	16	62.5
condition			n/a
subroutine	18	21	85.7
pod	6	6	100.0
total	97	113	85.8

package Worlogog::Incident;

use warnings;
use strict;

our $VERSION = '0.02';

use Carp qw(carp);
use Scope::OnExit::Wrap qw(on_scope_exit);
use Return::MultiLevel qw(with_return);
use Worlogog::Restart;
use Dispatch::Class qw(dispatch class_case);

use parent 'Exporter::Tiny';

our @EXPORT_OK = qw(
    handler_bind
    handler_case
    report
    error
    cerror
    warn
);

#our @CARP_NOT = qw(Worlogog::Restart);

our @handlers;
our $barrier;


# hakurei

sub handler_bind (&$) {
    my ($body, $handler) = @_;
    my $limit = @handlers;
    my $guard = on_scope_exit { splice @handlers, $limit };
    if (ref($handler) eq 'ARRAY') {
        $handler = dispatch @$handler;
    }
    push @handlers, \&$handler;
    $body->()
}

sub handler_case (&$) {
    my ($body, $genhandler) = @_;
    my $limit = @handlers;
    my $guard = on_scope_exit { splice @handlers, $limit };
    if (ref($genhandler) eq 'ARRAY') {
        $genhandler = class_case @$genhandler;
    }
    $genhandler = \&$genhandler;
    my $wantlist = wantarray;
    my @v = with_return {
        my ($return) = @_;
        push @handlers, sub {
            my $handler = $genhandler->(@_) or return;
            $return->($handler, @_);
        };
        unless (defined $wantlist) {
            $body->();
            return;
        }
        undef, $wantlist ? $body->() : scalar $body->()
    };
    if (my $f = shift @v) {
        return $f->(@v);
    }
    $wantlist ? @v : $v[0]
}


# reimu

sub report {
    my ($incident) = @_;
    my $limit = defined $barrier ? $barrier : $#handlers;
    for my $i (reverse 0 .. $limit) {
        my $h = $handlers[$i];
        local $barrier = $i - 1;
        $h->($incident);
    }
}

sub error {
    my ($incident) = @_;
    report $incident;
    die $incident;
}

sub cerror {
    my ($incident) = @_;
    Worlogog::Restart::case {
        error $incident;
    } {
        continue => sub {},
    };
}

sub warn {
    my ($incident) = @_;
    Worlogog::Restart::case {
        report $incident;
        carp $incident;
    } {
        muffle_warning => sub {},
    };
}

'ok'

__END__