libanyevent-callback-perl-0.06/0000755000000000000000000000000011773606004015153 5ustar rootrootlibanyevent-callback-perl-0.06/lib/0000775000000000000000000000000011773606004015723 5ustar rootrootlibanyevent-callback-perl-0.06/lib/AnyEvent/0000775000000000000000000000000011773606004017454 5ustar rootrootlibanyevent-callback-perl-0.06/lib/AnyEvent/Callback.pm0000664000000000000000000001717011773606004021514 0ustar rootrootpackage AnyEvent::Callback; use 5.010001; use strict; use warnings; require Exporter; use base 'Exporter'; use Carp; our @EXPORT = qw(CB CBS); our $VERSION = '0.06'; =head1 NAME AnyEvent::Callback - callback aggregator for L watchers. =head1 SYNOPSIS use AnyEvent::Callback; # usually watchers are looked as: AE::something @args, sub { ... }; AE::something @args, sub { ... }, # result sub { ... }; # error use AnyEvent::Callback; AE::something @args, CB { ... }; AE::something @args, CB sub { ... }, # result sub { ... }; # error AE::something @args, CB sub { ... }, # result sub { ... }, # error sub { ... }; # anyway callback Callback hierarchy my $cbchild = $cb->CB(sub { ... }); ... $cbchild->error('error'); # will call $cb->error('error'); Inside Your callback You can: sub my_watcher { my $cb = pop; my @args = @_; # ... $cb->error( @error ); # error callback will be called # or: $cb->( $value ); # result callback will be called } Callbacks stack my $cbs = CBS; for (1 .. $n) { AE::something @args, $cbs->cb; } $cbs->wait(sub { for (@_) { if ($_->is_error) { # handle one error my @err = $_->errors; # or: my $errstr = $_->errstr; } else { # results my @res = $_->results; } } }); =head1 DESCRIPTION The module allows You to create callback's hierarchy. Also the module groups error and result callbacks into one object. Also the module checks if one callback was called by watcher or not. If a watcher doesn't call result or error callback, error callback will be called automatically. Also the module checks if a callback was called reentrant. In the case the module will complain (using L). If a watcher touches error callback and if superior didn't define error callback, the module will call error callback upwards hierarchy. Example: AE::something @args, CB \&my_watcher, \&on_error; sub on_error { } sub my_watcher { my $cb = pop; ... the_other_watcher $cb->CB( sub { # error callback wasn't defined my $cb = pop; ... yet_another_watcher1 $cb->CB( sub { my $cb = pop; ... $cb->( 123 ); # upwards callback }); yet_another_watcher2 $cb->CB( sub { my $cb = pop; ... $cb->error( 456 ); # on_error will be called }); }); } =head1 METHODS =head2 'CODE' (overloaded fake method) $cb->( ... ); You can use the object as usually B. =cut use overload '&{}' => sub { my ($self) = shift; sub { $self->{called}++; carp "Repeated callback calling: $self->{called}" if $self->{called} > 1; carp "Calling result callback after error callback" if $self->{ecalled}; if ($self->{cb}) { $self->{cb}->(@_); $self->{acb}->() if $self->{acb}; } delete $self->{cb}; delete $self->{acb}; delete $self->{ecb}; delete $self->{parent}; return; }; }, bool => sub { 1 } # for 'if ($cb)' ; =head2 CB Creates new callback object that have binding on parent callback. my $new_cb = $cb->CB(sub { ... }); # the cb doesn't catch errors my $new_cb = CB(sub { ... }, sub { ... }); # the cb catches errors my $new_cb = $cb->CB(sub { ... }, sub { ... }); # the same =cut sub CB(&;&&) { my $parent; my ($cb, $ecb, $acb) = @_; ($parent, $cb, $ecb, $acb) = @_ unless 'CODE' eq ref $cb; croak 'Callback must be CODEREF' unless 'CODE' eq ref $cb; croak 'Error callback must be CODEREF or undef' unless 'CODE' eq ref $ecb or !defined $ecb; croak 'Anyway callback must be CODEREF or undef' unless 'CODE' eq ref $acb or !defined $acb; # don't translate erorrs upwards if error callback if exists $parent = undef if $ecb; my $self = bless { cb => $cb, ecb => $ecb, acb => $acb, parent => $parent, called => 0, ecalled => 0, } => __PACKAGE__; $self; } sub CBS { return AnyEvent::Callback::Stack->new; } =head2 error Calls error callback. If the object has no registered error callbacks, parent object's error callback will be called. $cb->error('WTF?'); =cut sub error { my ($self, @error) = @_; $self->{ecalled}++; carp "Repeated error callback calling: $self->{ecalled}" if $self->{ecalled} > 1; carp "Calling error callback after result callback" if $self->{called}; if ($self->{ecb}) { $self->{ecb}( @error ); $self->{acb}() if $self->{acb}; delete $self->{ecb}; delete $self->{cb}; delete $self->{parent}; delete $self->{acb}; return; } my $acb = delete $self->{acb}; delete $self->{ecb}; delete $self->{cb}; my $parent = delete $self->{parent}; if ($parent) { $parent->error( @error ); } else { carp "Uncaught error: @error"; } $acb->() if $acb; return; } sub DESTROY { my ($self) = @_; return if $self->{called} or $self->{ecalled}; $self->error("no one touched registered callback"); delete $self->{cb}; delete $self->{ecb}; } package AnyEvent::Callback::Stack; use Scalar::Util 'weaken'; use Carp; sub new { my ($class) = @_; return bless { stack => [], done => 0 } => ref($class) || $class; } sub cb { my ($self) = @_; my $idx = @{ $self->{stack} }; my $cb = AnyEvent::Callback::CB sub { $self->{stack}[$idx] = AnyEvent::Callback::Stack::Result->new(@_); $self->{done}++; $self->_check_if_done; }, sub { $self->{stack}[$idx] = AnyEvent::Callback::Stack::Result->err(@_); $self->{done}++; $self->_check_if_done; } ; push @{ $self->{stack} } => $cb; weaken $self->{stack}[$idx]; return $self->{stack}[$idx]; } sub _check_if_done { my ($self) = @_; return unless $self->{waiter}; return unless $self->{done} >= @{ $self->{stack} }; my $cb = delete $self->{waiter}; $cb->(@{ $self->{stack} }); $self->{stack} = []; $self->{done} = 0; } sub wait :method { my ($self, $cb) = @_; croak 'Usage: $cbs->wait(sub { ... })' unless 'CODE' eq ref $cb; croak 'You have already initiated wait process' if $self->{waiter}; $self->{waiter} = $cb; $self->_check_if_done; } package AnyEvent::Callback::Stack::Result; sub new { my ($class, @res) = @_; return bless { res => \@res } => ref($class) || $class; } sub err { my ($class, @res) = @_; return bless { err => \@res, res => [] } => ref($class) || $class; } sub is_error { my ($self) = @_; return exists $self->{err}; } sub results { my ($self) = @_; return $self->{res} unless wantarray; return @{ $self->{res} }; } sub errors { my ($self) = @_; return unless $self->is_error; return $self->{err} unless wantarray; return @{ $self->{err} }; } sub errstr { my ($self) = @_; return join ' ' => $self->errors; } =head1 COPYRIGHT AND LICENCE Copyright (C) 2012 by Dmitry E. Oboukhov This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; libanyevent-callback-perl-0.06/MANIFEST0000664000000000000000000000031511773606004016305 0ustar rootrootlib/AnyEvent/Callback.pm MANIFEST Makefile.PL Changes t/010-ae-cb.t t/030-ae-cbs.t t/020-pod.t debian/compat debian/rules debian/source/format debian/control debian/watch debian/changelog debian/copyright libanyevent-callback-perl-0.06/t/0000775000000000000000000000000011773606004015420 5ustar rootrootlibanyevent-callback-perl-0.06/t/010-ae-cb.t0000664000000000000000000001314211773606004017053 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 59; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'AnyEvent::Callback'; } # my ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err)= (0)x 5; my $cb = CB { $called++ }; isa_ok $cb => 'AnyEvent::Callback'; ok eval { $cb->(); 1 }, 'calling callback'; cmp_ok $called, '~~', 1, 'callback was called once'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb->error(); cmp_ok $#warns, '~~', 1, 'two warnings'; like $warns[0], qr{error callback after result}, 'first warning'; like $warns[1], qr{Uncaught error}, 'second warning'; } # ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++ }, sub { $ecalled++ }; isa_ok $cb => 'AnyEvent::Callback'; $cb->error(123); cmp_ok $ecalled, '~~', 1, 'error callback was touched'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb->(456); cmp_ok $#warns, '~~', 0, 'one warning'; like $warns[0], qr{result callback after error}, 'warning text'; } cmp_ok $ecalled, '~~', 1, 'error callback was touched once'; cmp_ok $called, '~~', 0, 'result callback was not touched'; is $acb, 0, 'anyway callback was not touched'; ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++ }, sub { $ecalled++ }, sub { $acb++ }; isa_ok $cb => 'AnyEvent::Callback'; $cb->error(123); cmp_ok $ecalled, '~~', 1, 'error callback was touched'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb->(456); cmp_ok $#warns, '~~', 0, 'one warning'; like $warns[0], qr{result callback after error}, 'warning text'; } cmp_ok $ecalled, '~~', 1, 'error callback was touched once'; cmp_ok $called, '~~', 0, 'result callback was not touched'; is $acb, 1, 'anyway callback was touched'; # ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++ }, sub { $ecalled++ }; isa_ok $cb => 'AnyEvent::Callback'; $cb->(123); cmp_ok $called, '~~', 1, 'result callback was touched'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb->error(456); cmp_ok $#warns, '~~', 1, 'warning twice'; like $warns[0], qr{error callback after result}, 'first warning'; like $warns[1], qr{Uncaught error}, 'first warning'; } cmp_ok $ecalled, '~~', 0, 'error callback was not touched'; cmp_ok $called, '~~', 1, 'result callback was touched once'; is $acb, 0, 'anyway callback was not touched'; ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++ }, sub { $ecalled++ }, sub { $acb++ }; isa_ok $cb => 'AnyEvent::Callback'; $cb->(123); cmp_ok $called, '~~', 1, 'result callback was touched'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb->error(456); cmp_ok $#warns, '~~', 1, 'warning twice'; like $warns[0], qr{error callback after result}, 'first warning'; like $warns[1], qr{Uncaught error}, 'first warning'; } cmp_ok $ecalled, '~~', 0, 'error callback was not touched'; cmp_ok $called, '~~', 1, 'result callback was touched once'; is $acb, 1, 'anyway callback touched'; # ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++; @res = @_ }, sub { $ecalled++; @err = @_ }; my $cb_child = $cb->CB(sub { $child_called++ }); undef $cb_child; cmp_ok $called, '~~', 0, "result callback wasn't touched"; cmp_ok $ecalled, '~~', 1, "error callback wasn touched once"; cmp_ok $child_called, '~~', 0, "child result callback wasn't touched"; cmp_ok $child_ecalled, '~~', 0, "child error callback wasn't touched"; like $err[0], qr{no one touched registered}, 'autotouch error callback'; # ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++; @res = @_ }, sub { $ecalled++; @err = @_ }; $cb_child = $cb->CB(sub { $child_called++ }, undef, sub { $acb++ }); undef $cb_child; is $called, 0, "result callback wasn't touched"; is $ecalled, 1, "error callback wasn touched once"; is $child_called, 0, "child result callback wasn't touched"; is $child_ecalled, 0, "child error callback wasn't touched"; is $acb, 1, 'anyway callback touched'; like $err[0], qr{no one touched registered}, 'autotouch error callback'; # ($called, $ecalled, $acb, $child_called, $child_ecalled, @res, @err) = (0) x 5; $cb = CB sub { $called++; @res = @_ }, sub { $ecalled++; @err = @_ }; $cb_child = $cb->CB(sub { $child_called++ }); $cb_child->error(12345); is $err[0], '12345', 'autotouch error callback'; cmp_ok $called, '~~', 0, "result callback wasn't touched"; cmp_ok $ecalled, '~~', 1, "error callback was touched once"; cmp_ok $child_called, '~~', 0, "child result callback wasn't touched"; cmp_ok $child_ecalled, '~~', 0, "child error callback wasn't touched"; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; $cb_child->(456); cmp_ok $#warns, '~~', 0, 'one warning'; like $warns[0], qr{result callback after error}, 'warning text'; } cmp_ok $called, '~~', 0, "result callback wasn't touched"; cmp_ok $ecalled, '~~', 1, "error callback was touched once"; cmp_ok $child_called, '~~', 0, "child result callback wasn't touched"; cmp_ok $child_ecalled, '~~', 0, "child error callback wasn't touched"; libanyevent-callback-perl-0.06/t/030-ae-cbs.t0000664000000000000000000000237311773606004017244 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 28; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'AnyEvent::Callback'; use_ok 'AnyEvent'; } for my $cv (AE::cv) { my @res; my $cbs = CBS; $cbs->wait(sub { @res = @_; $cv->send }); $cv->recv; cmp_ok scalar(@res), '~~', 0, 'empty list'; } for my $cv (AE::cv) { my @res; my $cbs = CBS; my @timers; for (1 .. 10) { push @timers => AE::timer rand .1, 0, $cbs->cb; } push @timers => AE::timer 0, 0, $cbs->cb; $cbs->wait(sub { @res = @_; $cv->send }); { $cbs->cb; } $cv->recv; cmp_ok scalar(@res), '~~', 12, 'stack list'; for (0 .. $#res) { isa_ok $res[$_] => 'AnyEvent::Callback::Stack::Result'; if ($_ < $#res) { ok !$res[$_]->is_error, 'not error' ; } else { ok $res[$_]->is_error, 'forgotten callback'; } } } libanyevent-callback-perl-0.06/t/020-pod.t0000664000000000000000000000041711773606004016670 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); BEGIN { use Test::More; eval 'use Test::Pod 1.00'; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; }; all_pod_files_ok( all_pod_files ); libanyevent-callback-perl-0.06/Changes0000664000000000000000000000063111773606004016450 0ustar rootrootRevision history for Perl extension AnyEvent::Callback. 0.01 Sat Jun 2 13:55:23 2012 - original version; created by h2xs 1.23 with options -X -n AnyEvent::Callback 0.02 Sat Jun 2 22:05:30 MSK 2012 - debian package 0.03 Sun Jun 3 00:55:56 MSK 2012 - typo in perldoc 0.05 Thu Jun 21 16:14:43 MSK 2012 - cbstack 0.06 Sat Jun 30 18:20:38 MSK 2012 - anyway callback libanyevent-callback-perl-0.06/README.pod0000777000000000000000000000000011773606004023142 2lib/AnyEvent/Callback.pmustar rootrootlibanyevent-callback-perl-0.06/Makefile.PL0000664000000000000000000000132011773606004017123 0ustar rootrootuse 5.010001; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'AnyEvent::Callback', VERSION_FROM => 'lib/AnyEvent/Callback.pm', PREREQ_PM => {}, BUILD_REQUIRES => { AnyEvent => 0, }, ABSTRACT_FROM => 'lib/AnyEvent/Callback.pm', AUTHOR => 'Dmitry E. Oboukhov ', META_MERGE => { resources => { homepage => 'https://github.com/unera/libanyevent-callback', bugtracker => 'https://github.com/unera/libanyevent-callback/issues', } }, LICENSE => 'perl' );