libanyevent-forkobject-perl-0.09/0000775000000000000000000000000011614512463015553 5ustar rootrootlibanyevent-forkobject-perl-0.09/README0000644000000000000000000000225711531660512016434 0ustar rootrootAnyEvent-ForkObject version 0.01 ================================ The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it get an idea of the modules uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: blah blah blah COPYRIGHT AND LICENCE Put the correct copyright and licence information here. Copyright (C) 2011 by Dmitry E. Oboukhov This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.10.1 or, at your option, any later version of Perl 5 you may have available. libanyevent-forkobject-perl-0.09/Makefile.PL0000644000000000000000000000172611534103475017531 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::ForkObject', VERSION_FROM => 'lib/AnyEvent/ForkObject.pm', # finds $VERSION PREREQ_PM => { 'AnyEvent::Tools' => '0.10', 'AnyEvent::Serialize' => '0.03', 'Devel::GlobalDestruction' => '0.02' }, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/AnyEvent/ForkObject.pm', # retrieve abstract from module AUTHOR => 'Dmitry E. Oboukhov ') : ()), ); # I wanna see full report on CPAN if (open my $file, '+<', 'Makefile') { my @lines = <$file>; seek $file, 0, 0; truncate $file, 0; for (@lines) { $_ = "TEST_VERBOSE=1\n" if /^TEST_VERBOSE\s*=\s*.*/; print $file $_; } } libanyevent-forkobject-perl-0.09/t/0000775000000000000000000000000011534642474016025 5ustar rootrootlibanyevent-forkobject-perl-0.09/t/02_dbi.t0000644000000000000000000000753611533124047017250 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More; use Encode qw(decode encode); use File::Temp qw(tempfile tempdir); use File::Spec::Functions qw(catfile); use File::Path qw(remove_tree); BEGIN { my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; eval { require DBI; require DBD::SQLite; }; if ($@) { plan skip_all => "DBD::SQLite isn't installed properly"; } else { plan tests => 12; } use_ok 'AnyEvent'; use_ok 'AnyEvent::ForkObject'; use_ok 'AnyEvent::Tools', 'async_repeat'; } sub rand_str(); our $tmp_dir = tempdir; END { remove_tree $tmp_dir if $tmp_dir and -d $tmp_dir }; my $cv = condvar AnyEvent; my $fo = new AnyEvent::ForkObject; my $db_file = catfile $tmp_dir, 'db.sqlite'; my $dbh; $fo->do( method => 'connect', module => 'DBI', args => [ "dbi:SQLite:dbname=$db_file", '', '', { RaiseError => 1 } ], cb => sub { my ($s, $db) = @_; $dbh = $db; ok $s eq 'ok', 'DBI connected'; $dbh->do(q{ CREATE TABLE tbl ( id INTEGER PRIMARY KEY AUTOINCREMENT, txt TEXT NOT NULL ) }, sub { my ($s, $res) = @_; diag explain \@_ unless ok $s eq 'ok', 'Table "tbl" was created'; my $count = 0; my $ok = 1; for (1 .. 50) { $dbh->do('INSERT INTO tbl (txt) VALUES (?)', undef, rand_str, sub { my ($s, $res) = @_; unless ($s eq 'ok') { diag explain \@_; $ok = 0; } if (++$count == 50) { ok $ok, '50 records were inserted'; $dbh->selectall_arrayref( 'SELECT * FROM tbl', { Slice => {} }, sub { my ($s, $res) = @_; ok $s eq 'ok', 'SELECT was done'; ok @$res == 50, 'Fetched all rows'; ok 'HASH' eq ref $res->[0], 'Slice works properly'; $cv->send; } ); } } ); } }); } ); $cv->recv; $cv = condvar AnyEvent; $dbh->prepare('SELECT * FROM tbl', sub { my ($s, $sth) = @_; ok $s eq 'ok', 'Prepare statement'; $sth->execute(sub { my ($s, $rv) = @_; ok $s eq 'ok', 'Execute statement'; my $ok = 1; async_repeat 50, sub { my ($guard, $index, $first, $last) = @_; $sth->fetchrow_hashref(sub { undef $guard; my ($s, $row) = @_; $ok = 0 unless $s eq 'ok'; $ok = 0 unless 'HASH' eq ref $row; $ok = 0 unless $row->{id} == $index + 1; if ($last) { ok $ok, 'All data fetched'; undef $sth; undef $dbh; my $t; $t = AE::timer 0.5, 0 => sub { undef $t; $cv->send; } } }); }; }); }); $cv->recv; sub rand_str() { my $letters = q!qwertyuiopasdfghjkl;'][zxcvbnm,./йцукенгшщзхъфывапролджэ!; my $str = ''; $str .= substr $letters, int(rand length $letters), 1 for 0 .. 3 + rand 100; return $str; } libanyevent-forkobject-perl-0.09/t/01_fo.t0000644000000000000000000001601511534642474017117 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 => 39; use Encode qw(decode encode); BEGIN { my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'AnyEvent'; use_ok 'AnyEvent::ForkObject'; } { my $cv = condvar AnyEvent; my $obj = new AnyEvent::ForkObject; ok $obj, "Constructor"; my $phase = 0; $obj->do(require => 'Data::Dumper', cb => sub { $phase++; diag explain \@_ unless ok $_[0] eq 'ok', 'require Data::Dumper'; $obj->do( module => 'Data::Dumper', args => [ [ 1, 2, 3 ]], cb => sub { my ($s, $o) = @_; diag explain \@_ unless ok $s eq 'ok', 'Data::Dumper created'; $phase++; $o->Indent(0, sub { ok $_[0] eq 'ok', 'dumper->Indent(0)' }); $o->Terse(1, sub { ok $_[0] eq 'ok', 'dumper->Terse(1)' }); $o->Useqq(1, sub { ok $_[0] eq 'ok', 'dumper->Useqq(1)' }); $o->Deepcopy(1, sub { ok $_[0] eq 'ok', 'dumper->Deepcopy(1)' } ); $o->Dump(sub { my ($st, $ob) = @_; undef $o; $phase++; ok $st eq 'ok', 'Dump has done'; ok $ob eq '123', 'Result is right'; }, 0); }); }); $obj->do(require => 'File::Spec', cb => sub { diag explain \@_ unless ok $_[0] eq 'ok', 'require File::Spec'; $phase++; $obj->do( module => 'File::Spec', method => 'catfile', args => [ '/etc', 'passwd' ], cb => sub { my ($s, $o) = @_; $phase++; ok $s eq 'ok', 'File::Spec->catfile has done'; ok $o eq '/etc/passwd', 'File::Spec->catfile works properly'; } ); }); my $timer = AE::timer 0.01, 0.01 => sub { return if $phase < 5; undef $obj; $cv->send }; my $timeout; $timeout = AE::timer 2, 0 => sub { undef $obj; undef $timeout; $cv->send }; $cv->recv; ok $timeout, "Timeout wasn't reached"; } { my $cv = condvar AnyEvent; my $obj = new AnyEvent::ForkObject; ok $obj, "Constructor"; $obj->do(require => 'Data::Dumper', cb => sub { diag explain \@_ unless ok $_[0] eq 'ok', 'require Data::Dumper'; $obj->do( module => 'Data::Dumper', args => [ [ 1, 2, 3 ]], cb => sub { my ($s, $o) = @_; ok $s eq 'ok', 'Data::Dumper created'; undef $obj; $o->Dump(0, sub { my ($st, $ob) = @_; ok $st eq 'fatal', 'Object has been destroyed'; ok $ob =~ /destroyed/, 'Fatal message is right'; }); }); }); my $timer = AE::timer 1, 0 => sub { $cv->send }; $cv->recv; } { my $cv = condvar AnyEvent; my $obj = new AnyEvent::ForkObject; my $obj2 = new AnyEvent::ForkObject; ok $obj, "Constructor"; kill KILL => $obj->{pid}; waitpid $obj->{pid}, 0; $obj->do(require => 'Data::Dumper', cb => sub { diag explain \@_ unless ok $_[0] eq 'fatal', 'Child was killed'; my $t; $t = AE::timer 0.3, 0 => sub { undef $t; $cv->send; } }); my $dont_call_if_destroyed = 1; $obj2->do(require => 'Data::Dumper', cb => sub { diag explain \@_; $dont_call_if_destroyed = 0; }); kill KILL => $obj2->{pid}; undef $obj2; my $timeout; $timeout = AE::timer 1, 0 => sub { undef $timeout; $cv->send }; $cv->recv; ok $dont_call_if_destroyed, "Don't touch callbacks if destroyed"; ok $timeout, "Timeout wasn't reached"; } package FO_Test; sub new { bless { val => $_[1] } => __PACKAGE__; } sub val { return $_[0]{val} if @_ == 1; return $_[0]{val} = $_[1]; } package FO_Test2; sub new { bless [ 10, 20, $_[1] ] => __PACKAGE__; } sub val { return $_[0][2] if @_ == 1; return $_[0][2] = $_[1]; } package main; { my $cv = condvar AnyEvent; my $obj = new AnyEvent::ForkObject; ok $obj, "Constructor"; $obj->do( module => 'FO_Test', args => [ 123 ], cb => sub { my ($s, $o) = @_; ok $s eq 'ok', 'FO_Test constructor'; $o->val(sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 123, "FO_Test->val"; $o->val(234, sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 234, "FO_Test->val(234)"; $o->fo_attr(val => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 234, "FO_Test->fo_attr('val')"; $o->fo_attr(val => 456 => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 456, "FO_Test->fo_attr('val' => 456)"; $o->val(sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 456, "FO_Test->val"; }); }); }); }); }); }); $obj->do( module => 'FO_Test2', args => [ 123 ], cb => sub { my ($s, $o) = @_; ok $s eq 'ok', 'FO_Test2 constructor'; $o->val(sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 123, "FO_Test2->val"; $o->val(234, sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 234, "FO_Test2->val(234)"; $o->fo_attr(0 => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 10, "FO_Test2->fo_attr(0)"; }); $o->fo_attr(1 => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 20, "FO_Test2->fo_attr(1)"; }); $o->fo_attr(2 => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 234, "FO_Test2->fo_attr(2)"; $o->fo_attr(2 => 456 => sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 456, "FO_Test2->fo_attr(2 => 456)"; $o->val(sub { my ($s, $v) = @_; ok $s eq 'ok' && $v == 456, "FO_Test2->val"; }); }); }); }); }); }); my $timer = AE::timer 0.5, 0 => sub { $cv->send }; $cv->recv; } libanyevent-forkobject-perl-0.09/MANIFEST0000664000000000000000000000024011533424533016700 0ustar rootrootChanges debian/changelog debian/compat debian/control debian/copyright debian/rules lib/AnyEvent/ForkObject.pm Makefile.PL MANIFEST README t/01_fo.t t/02_dbi.t libanyevent-forkobject-perl-0.09/Changes0000644000000000000000000000127111534643724017053 0ustar rootrootRevision history for Perl extension AnyEvent::ForkObject. 0.01 Fri Feb 25 10:59:06 2011 - original version; created by h2xs 1.23 with options -Xn AnyEvent::ForkObject 0.02 Mon Feb 28 00:00:21 MSK 2011 - fixed MANIFEST - added debian infrastructure 0.04 Mon Feb 28 00:40:44 MSK 2011 - clean zombies. 0.05 Tue Mar 1 10:14:18 MSK 2011 - perldoc - separate global and usual destructor to avoid EV crash 0.06 Wed Mar 2 14:24:59 MSK 2011 - destructors work properly 0.07 Fri Mar 4 09:34:26 MSK 2011 - test verbose = TRUE 0.08 Sun Mar 6 11:36:52 MSK 2011 - detect if child was killed properly (thanks for CPAN testers report). libanyevent-forkobject-perl-0.09/lib/0000775000000000000000000000000011531660512016316 5ustar rootrootlibanyevent-forkobject-perl-0.09/lib/AnyEvent/0000775000000000000000000000000011614512442020047 5ustar rootrootlibanyevent-forkobject-perl-0.09/lib/AnyEvent/ForkObject.pm0000644000000000000000000002723411614512442022443 0ustar rootrootpackage AnyEvent::ForkObject; use 5.010001; use strict; use warnings; use Carp; use AnyEvent; use AnyEvent::Util; use AnyEvent::Handle; use Scalar::Util qw(weaken blessed reftype); use POSIX; use IO::Handle; use AnyEvent::Serialize qw(:all); use AnyEvent::Tools qw(mutex); use Devel::GlobalDestruction; our $VERSION = '0.09'; sub new { my ($class) = @_; my $self = bless { } => ref($class) || $class; my ($s1, $s2) = portable_socketpair; if ($self->{pid} = fork) { # parent $self->{mutex} = mutex; close $s2; fh_nonblocking $s1, 1; { weaken(my $self = $self); $self->{handle} = new AnyEvent::Handle fh => $s1, on_error => sub { return unless $self; return if $self->{destroyed}; delete $self->{handle}; $self->{fatal} = $!; $self->{cb}(fatal => $self->{fatal}) if $self->{cb}; }; } } elsif (defined $self->{pid}) { # child close $s1; $self->{socket} = $s2; $self->{object} = {}; $self->{no} = 0; $self->_start_server; } else { die $!; } return $self; } sub do :method { my ($self, %opts) = @_; my $method = $opts{method} || 'new'; my $invocant = $opts{module} || $opts{_invocant}; my $cb = $opts{cb} || sub { }; my $args = $opts{args} || []; my $wantarray = $opts{wantarray}; my $require = $opts{require}; $wantarray = 0 unless exists $opts{wantarray}; weaken $self; $self->{mutex}->lock(sub { my ($guard) = @_; return unless $self; return if $self->{destroyed}; $self->{cb} = $cb; unless ($self->{handle}) { $cb->(fatal => 'Child process was destroyed'); undef $guard; return; } if ($self->{fatal}) { $cb->(fatal => $self->{fatal}); delete $self->{cb}; undef $guard; return; } serialize { $require ? (r => $require) : ( i => $invocant, m => $method, a => $args, wa => $wantarray ) } => sub { return unless $self; return if $self->{destroyed} or $self->{fatal}; $self->{handle}->push_write("$_[0]\n"); return unless $self; return if $self->{destroyed} or $self->{fatal}; $self->{handle}->push_read(line => "\n", sub { deserialize $_[1] => sub { return unless $self; return if $self->{destroyed} or $self->{fatal}; my ($o, $error, $tail) = @_; if ($error) { $cb->(fatal => $error); delete $self->{cb}; undef $guard; return; } my $status = shift @$o; if ($status eq 'ok') { for (@$o) { if (exists $_->{obj}) { $_ = bless { no => "$_->{obj}", fo => \$self, } => 'AnyEvent::ForkObject::OneObject'; next; } $_ = $_->{res}; } $cb->(ok => @$o); } else { $cb->($status => @$o); } delete $self->{cb}; undef $guard; }; return; }); return; }; }); return; } sub DESTROY { my ($self) = @_; $self->{destroyed} = 1; $self->{handle}->push_write("'bye'\n") if $self->{handle}; delete $self->{handle}; return if in_global_destruction; # kill zombies my $cw; $cw = AE::child $self->{pid} => sub { my ($pid, $code) = @_; undef $cw; }; } sub _start_server { my ($self) = @_; croak "Something wrong" if $self->{pid}; my $err_code = 0; require Data::StreamSerializer; my $socket = $self->{socket}; $socket->autoflush(1); while(<$socket>) { my $response; next unless /\S/; my $cmd = eval $_; if ($@) { $err_code = 1; last; } unless (ref $cmd) { if ($cmd eq 'bye') { undef $_ for values %{ $self->{object} }; delete $self->{object}; last; } eval $cmd; if ($@) { $response = [ die => $@ ]; goto RESPONSE; } $response = [ 'ok' ]; goto RESPONSE; } # require if ($cmd->{r}) { eval "require $cmd->{r}"; if ($@) { $response = [ die => $@ ]; goto RESPONSE; } $response = [ 'ok' ]; goto RESPONSE; } my ($invocant, $method, $args, $wantarray) = @$cmd{qw(i m a wa)}; if ($invocant =~ /^\d+$/) { if ($method eq 'DESTROY') { delete $self->{object}{$invocant}; $response = [ 'ok' ]; goto RESPONSE; } else { $invocant = $self->{object}{$invocant} } } my @o; if ($method eq 'fo_attr') { unless (ref $invocant) { $response = [ die => 'fo_attr should be called as method' ]; goto RESPONSE; } if ('ARRAY' eq reftype $invocant) { $invocant->[ $args->[0] ] = $args->[1] if @$args > 1; $o[0] = $invocant->[ $args->[0] ]; } elsif ('HASH' eq reftype $invocant) { $invocant->{ $args->[0] } = $args->[1] if @$args > 1; $o[0] = $invocant->{ $args->[0] }; } else { $response = [ die => "fo_attr can't access on blessed " . reftype $invocant ]; goto RESPONSE; } } else { if ($wantarray) { @o = eval { $invocant -> $method ( @$args ) }; } elsif (defined $wantarray) { $o[0] = eval { $invocant -> $method ( @$args ) }; } else { eval { $invocant -> $method ( @$args ) }; } if ($@) { $response = [ die => $@ ]; goto RESPONSE; } } for (@o) { if (ref $_ and blessed $_) { my $no = ++$self->{no}; $self->{object}{$no} = $_; $_ = { obj => $no }; next; } $_ = { res => $_ }; } $response = [ ok => @o ]; RESPONSE: my $sr = new Data::StreamSerializer($response); while(defined(my $part = $sr->next)) { print $socket $part; } print $socket "\n"; } # destroy internal objects delete $self->{object}; # we don't want to call any other destructors POSIX::_exit($err_code); } package AnyEvent::ForkObject::OneObject; use Carp; use Scalar::Util qw(blessed); use Devel::GlobalDestruction; sub AUTOLOAD { our $AUTOLOAD; my ($foo) = $AUTOLOAD =~ /([^:]+)$/; my ($self, @args) = @_; my $cb = pop @args; my $wantarray = 0; if ('CODE' ne ref $cb) { $wantarray = $cb; $cb = pop @args; } croak "Callback is required" unless 'CODE' eq ref $cb; my $fo = $self->{fo}; unless ($$fo) { $cb->(fatal => 'Child process was already destroyed'); return; } $$fo -> do( _invocant => $self->{no}, method => $foo, args => \@args, cb => $cb, wantarray => $wantarray ); return; } sub DESTROY { # You can call DESTROY by hand my ($self, $cb) = @_; return if in_global_destruction; $cb ||= sub { }; my $fo = $self->{fo}; unless (blessed $$fo) { $cb->(fatal => 'Child process was already destroyed'); return; } $$fo -> do( _invocant => $self->{no}, method => 'DESTROY', cb => $cb, wantarray => undef, ); return; } 1; __END__ =head1 NAME AnyEvent::ForkObject - Async access on objects. =head1 SYNOPSIS use AnyEvent::ForkObject; use DBI; my $fo = new AnyEvent::ForkObject; $fo->do( module => 'DBI', method => 'connect', args => [ 'dbi:mysql...' ], cb => sub { my ($status, $dbh) = @_; $dbh->selectrow_array('SELECT ?', undef, 1 + 1, sub { my ($status, $result) = @_; print "$result\n"; # prints 2 }); } ); use AnyEvent::Tools qw(async_repeat); $dbh->prepare('SELECT * FROM tbl', sub { my ($status, $sth) = @_; $sth->execute(sub { my ($status, $rv) = @_; # fetch 30 rows async_repeat 30 => sub { my ($guard) = @_; $sth->fetchrow_hashref(sub { my ($status, $row) = @_; undef $guard; # do something with $row }); }; }); }); =head1 DESCRIPTION There are a lot of modules that provide object interface. Using the module You can use them in async mode. =head1 METHODS =head2 new Constructor. Creates an instance that contains fork jail. =head2 do Creates an object inside jail. It receives the following named arguments: =over =item B Do B inside jail. If the argument is exists, B, B and B arguments will be ignored. =item B Module name. For example 'B'. =item B Constructor name. Default value is 'B'. =item B Context for method. Default is B<0> (SCALAR). =item B Done callback. The first argument is a status: =over =item B The method has thrown exception. The next argument contains B<$@>. =item B A fatal error was occured (for example fork jail was killed). =item B Method has done. The following arguments contain all data that were returned by the method. =back =back If L returns blessed object, it will provide all its methods in modified form. Each method will receive one or two additional arguments: =over =item B A callback that will be called after method has done. =item B Context flag for method. Default value is B<0> (SCALAR). =back All objects provide additional method B to access their field. Example: # set attribute $dbh->fo_attr(RaiseError => 1, sub { my ($status, $attr) = @_; ... }); # get attribute $dbh->fo_attr('RaiseError', sub { my ($status, $attr) = @_; ... }); =head1 AUTHOR Dmitry E. Oboukhov, Eunera@debian.orgE =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 by Dmitry E. Oboukhov This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.10.1 or, at your option, any later version of Perl 5 you may have available. =head1 VCS The project is placed in my git repo: L =cut