AnyEvent-DBI-2.2/0000755000000000000000000000000011755057524012213 5ustar rootrootAnyEvent-DBI-2.2/DBI.pm0000644000000000000000000004272311755057320013151 0ustar rootroot=head1 NAME AnyEvent::DBI - asynchronous DBI access =head1 SYNOPSIS use AnyEvent::DBI; my $cv = AnyEvent->condvar; my $dbh = new AnyEvent::DBI "DBI:SQLite:dbname=test.db", "", ""; $dbh->exec ("select * from test where num=?", 10, sub { my ($dbh, $rows, $rv) = @_; $#_ or die "failure: $@"; print "@$_\n" for @$rows; $cv->broadcast; }); # asynchronously do sth. else here $cv->wait; =head1 DESCRIPTION This module is an L user, you need to make sure that you use and run a supported event loop. This module implements asynchronous DBI access by forking or executing separate "DBI-Server" processes and sending them requests. It means that you can run DBI requests in parallel to other tasks. The overhead for very simple statements ("select 0") is somewhere around 100% to 120% (dual/single core CPU) compared to an explicit prepare_cached/execute/fetchrow_arrayref/finish combination. =head2 ERROR HANDLING This module defines a number of functions that accept a callback argument. All callbacks used by this module get their AnyEvent::DBI handle object passed as first argument. If the request was successful, then there will be more arguments, otherwise there will only be the C<$dbh> argument and C<$@> contains an error message. A convinient way to check whether an error occured is to check C<$#_> - if that is true, then the function was successful, otherwise there was an error. =cut package AnyEvent::DBI; use common::sense; use Carp; use Socket (); use Scalar::Util (); use Storable (); use DBI (); # only needed in child actually - do it before fork & !exec? use AnyEvent (); use AnyEvent::Util (); use Errno (); use Fcntl (); use POSIX (); our $VERSION = '2.2'; our $FD_MAX = eval { POSIX::sysconf (&POSIX::_SC_OPEN_MAX) - 1 } || 1023; # this is the forked server code, could/should be bundled as it's own file our $DBH; sub req_open { my (undef, $dbi, $user, $pass, %attr) = @{+shift}; $DBH = DBI->connect ($dbi, $user, $pass, \%attr) or die $DBI::errstr; [1, 1] } sub req_exec { my (undef, $st, @args) = @{+shift}; my $sth = $DBH->prepare_cached ($st, undef, 1) or die [$DBI::errstr]; my $rv = $sth->execute (@args) or die [$sth->errstr]; [1, $sth->{NUM_OF_FIELDS} ? $sth->fetchall_arrayref : undef, $rv] } sub req_attr { my (undef, $attr_name, @attr_val) = @{+shift}; $DBH->{$attr_name} = $attr_val[0] if @attr_val; [1, $DBH->{$attr_name}] } sub req_begin_work { [1, $DBH->begin_work or die [$DBI::errstr]] } sub req_commit { [1, $DBH->commit or die [$DBI::errstr]] } sub req_rollback { [1, $DBH->rollback or die [$DBI::errstr]] } sub req_func { my (undef, $arg_string, $function) = @{+shift}; my @args = eval $arg_string; die "error evaling \$dbh->func() arg_string: $@" if $@; my $rc = $DBH->func (@args, $function); return [1, $rc, $DBI::err, $DBI::errstr]; } sub serve_fh($$) { my ($fh, $version) = @_; if ($VERSION != $version) { syswrite $fh, pack "L/a*", Storable::freeze [undef, "AnyEvent::DBI version mismatch ($VERSION vs. $version)"]; return; } eval { my $rbuf; while () { sysread $fh, $rbuf, 16384, length $rbuf or last; while () { my $len = unpack "L", $rbuf; # full request available? last unless $len && $len + 4 <= length $rbuf; my $req = Storable::thaw substr $rbuf, 4; substr $rbuf, 0, $len + 4, ""; # remove length + request my $wbuf = eval { pack "L/a*", Storable::freeze $req->[0]($req) }; $wbuf = pack "L/a*", Storable::freeze [undef, ref $@ ? ("$@->[0]", $@->[1]) : ("$@", 1)] if $@; for (my $ofs = 0; $ofs < length $wbuf; ) { $ofs += (syswrite $fh, substr $wbuf, $ofs or die "unable to write results"); } } } }; } sub serve_fd($$) { open my $fh, ">>&=$_[0]" or die "Couldn't open server file descriptor: $!"; serve_fh $fh, $_[1]; } =head2 METHODS =over 4 =item $dbh = new AnyEvent::DBI $database, $user, $pass, [key => value]... Returns a database handle for the given database. Each database handle has an associated server process that executes statements in order. If you want to run more than one statement in parallel, you need to create additional database handles. The advantage of this approach is that transactions work as state is preserved. Example: $dbh = new AnyEvent::DBI "DBI:mysql:test;mysql_read_default_file=/root/.my.cnf", "", ""; Additional key-value pairs can be used to adjust behaviour: =over 4 =item on_error => $callback->($dbh, $filename, $line, $fatal) When an error occurs, then this callback will be invoked. On entry, C<$@> is set to the error message. C<$filename> and C<$line> is where the original request was submitted. If the fatal argument is true then the database connection is shut down and your database handle became invalid. In addition to invoking the C callback, all of your queued request callbacks are called without only the C<$dbh> argument. If omitted, then C will be called on any errors, fatal or not. =item on_connect => $callback->($dbh[, $success]) If you supply an C callback, then this callback will be invoked after the database connect attempt. If the connection succeeds, C<$success> is true, otherwise it is missing and C<$@> contains the C<$DBI::errstr>. Regardless of whether C is supplied, connect errors will result in C being called. However, if no C callback is supplied, then connection errors are considered fatal. The client will C and the C callback will be called with C<$fatal> true. When on_connect is supplied, connect error are not fatal and AnyEvent::DBI will not C. You still cannot, however, use the $dbh object you received from C to make requests. =item exec_server => 1 If you supply an C argument, then the DBI server process will fork and exec another perl interpreter (using C<$^X>) with just the AnyEvent::DBI proxy running. This will provide the cleanest possible proxy for your database server. If you do not supply the C argument (or supply it with a false value) then the traditional method of starting the server by forking the current process is used. The forked interpreter will try to clean itself up by calling POSIX::close on all file descriptors except STDIN, STDOUT, and STDERR (and the socket it uses to communicate with the cilent, of course). =item timeout => seconds If you supply a timeout parameter (fractional values are supported), then a timer is started any time the DBI handle expects a response from the server. This includes connection setup as well as requests made to the backend. The timeout spans the duration from the moment the first data is written (or queued to be written) until all expected responses are returned, but is postponed for "timeout" seconds each time more data is returned from the server. If the timer ever goes off then a fatal error is generated. If you have an C handler installed, then it will be called, otherwise your program will die(). When altering your databases with timeouts it is wise to use transactions. If you quit due to timeout while performing insert, update or schema-altering commands you can end up not knowing if the action was submitted to the database, complicating recovery. Timeout errors are always fatal. =back Any additional key-value pairs will be rolled into a hash reference and passed as the final argument to the C<< DBI->connect (...) >> call. For example, to supress errors on STDERR and send them instead to an AnyEvent::Handle you could do: $dbh = new AnyEvent::DBI "DBI:mysql:test;mysql_read_default_file=/root/.my.cnf", "", "", PrintError => 0, on_error => sub { $log_handle->push_write ("DBI Error: $@ at $_[1]:$_[2]\n"); }; =cut # stupid Storable autoloading, total loss-loss situation Storable::thaw Storable::freeze []; sub new { my ($class, $dbi, $user, $pass, %arg) = @_; my ($client, $server) = AnyEvent::Util::portable_socketpair or croak "unable to create AnyEvent::DBI communications pipe: $!"; my %dbi_args = %arg; delete @dbi_args{qw(on_connect on_error timeout exec_server)}; my $self = bless \%arg, $class; $self->{fh} = $client; AnyEvent::Util::fh_nonblocking $client, 1; my $rbuf; my @caller = (caller)[1,2]; # the "default" caller { Scalar::Util::weaken (my $self = $self); $self->{rw} = AE::io $client, 0, sub { return unless $self; my $len = sysread $client, $rbuf, 65536, length $rbuf; if ($len > 0) { # we received data, so reset the timer $self->{last_activity} = AE::now; while () { my $len = unpack "L", $rbuf; # full response available? last unless $len && $len + 4 <= length $rbuf; my $res = Storable::thaw substr $rbuf, 4; substr $rbuf, 0, $len + 4, ""; # remove length + request last unless $self; my $req = shift @{ $self->{queue} }; if (defined $res->[0]) { $res->[0] = $self; $req->[0](@$res); } else { my $cb = shift @$req; local $@ = $res->[1]; $cb->($self); $self->_error ($res->[1], @$req, $res->[2]) # error, request record, is_fatal if $self; # cb() could have deleted it } # no more queued requests, so become idle if ($self && !@{ $self->{queue} }) { undef $self->{last_activity}; $self->{tw_cb}->(); } } } elsif (defined $len) { # todo, caller? $self->_error ("unexpected eof", @caller, 1); } elsif ($! != Errno::EAGAIN) { # todo, caller? $self->_error ("read error: $!", @caller, 1); } }; $self->{tw_cb} = sub { if ($self->{timeout} && $self->{last_activity}) { if (AE::now > $self->{last_activity} + $self->{timeout}) { # we did time out my $req = $self->{queue}[0]; $self->_error (timeout => $req->[1], $req->[2], 1); # timeouts are always fatal } else { # we need to re-set the timeout watcher $self->{tw} = AE::timer $self->{last_activity} + $self->{timeout} - AE::now, 0, $self->{tw_cb}, ; } } else { # no timeout check wanted, or idle undef $self->{tw}; } }; $self->{ww_cb} = sub { return unless $self; $self->{last_activity} = AE::now; my $len = syswrite $client, $self->{wbuf} or return delete $self->{ww}; substr $self->{wbuf}, 0, $len, ""; }; } my $pid = fork; if ($pid) { # parent close $server; } elsif (defined $pid) { # child my $serv_fno = fileno $server; if ($self->{exec_server}) { fcntl $server, &Fcntl::F_SETFD, 0; # don't close the server side exec {$^X} "$0 dbi slave", -e => "require shift; AnyEvent::DBI::serve_fd ($serv_fno, $VERSION)", $INC{"AnyEvent/DBI.pm"}; POSIX::_exit 124; } else { ($_ != $serv_fno) && POSIX::close $_ for $^F+1..$FD_MAX; serve_fh $server, $VERSION; # no other way on the broken windows platform, even this leaks # memory and might fail. kill 9, $$ if AnyEvent::WIN32; # and this kills the parent process on windows POSIX::_exit 0; } } else { croak "fork: $!"; } $self->{child_pid} = $pid; $self->_req ( ($self->{on_connect} ? $self->{on_connect} : sub { }), (caller)[1,2], req_open => $dbi, $user, $pass, %dbi_args ); $self } sub _server_pid { shift->{child_pid} } sub kill_child { my $self = shift; if (my $pid = delete $self->{child_pid}) { # kill and reap process my $kid_watcher; $kid_watcher = AE::child $pid, sub { undef $kid_watcher; }; kill TERM => $pid; } close delete $self->{fh}; } sub DESTROY { shift->kill_child; } sub _error { my ($self, $error, $filename, $line, $fatal) = @_; if ($fatal) { delete $self->{tw}; delete $self->{rw}; delete $self->{ww}; delete $self->{fh}; # for fatal errors call all enqueued callbacks with error while (my $req = shift @{$self->{queue}}) { local $@ = $error; $req->[0]->($self); } $self->kill_child; } local $@ = $error; if ($self->{on_error}) { $self->{on_error}($self, $filename, $line, $fatal) } else { die "$error at $filename, line $line\n"; } } =item $dbh->on_error ($cb->($dbh, $filename, $line, $fatal)) Sets (or clears, with C) the C handler. =cut sub on_error { $_[0]{on_error} = $_[1]; } =item $dbh->timeout ($seconds) Sets (or clears, with C) the database timeout. Useful to extend the timeout when you are about to make a really long query. =cut sub timeout { my ($self, $timeout) = @_; $self->{timeout} = $timeout; # reschedule timer if one was running $self->{tw_cb}->(); } sub _req { my ($self, $cb, $filename, $line) = splice @_, 0, 4, (); unless ($self->{fh}) { local $@ = my $err = 'no database connection'; $cb->($self); $self->_error ($err, $filename, $line, 1); return; } push @{ $self->{queue} }, [$cb, $filename, $line]; # re-start timeout if necessary if ($self->{timeout} && !$self->{tw}) { $self->{last_activity} = AE::now; $self->{tw_cb}->(); } $self->{wbuf} .= pack "L/a*", Storable::freeze \@_; unless ($self->{ww}) { my $len = syswrite $self->{fh}, $self->{wbuf}; substr $self->{wbuf}, 0, $len, ""; # still any left? then install a write watcher $self->{ww} = AE::io $self->{fh}, 1, $self->{ww_cb} if length $self->{wbuf}; } } =item $dbh->exec ("statement", @args, $cb->($dbh, \@rows, $rv)) Executes the given SQL statement with placeholders replaced by C<@args>. The statement will be prepared and cached on the server side, so using placeholders is extremely important. The callback will be called with a weakened AnyEvent::DBI object as the first argument and the result of C as (or C if the statement wasn't a select statement) as the second argument. Third argument is the return value from the C<< DBI->execute >> method call. If an error occurs and the C callback returns, then only C<$dbh> will be passed and C<$@> contains the error message. =item $dbh->attr ($attr_name[, $attr_value], $cb->($dbh, $new_value)) An accessor for the handle attributes, such as C, C, C and so on. If you provide an C<$attr_value> (which might be C), then the given attribute will be set to that value. The callback will be passed the database handle and the attribute's value if successful. If an error occurs and the C callback returns, then only C<$dbh> will be passed and C<$@> contains the error message. =item $dbh->begin_work ($cb->($dbh[, $rc])) =item $dbh->commit ($cb->($dbh[, $rc])) =item $dbh->rollback ($cb->($dbh[, $rc])) The begin_work, commit, and rollback methods expose the equivalent transaction control method of the DBI driver. On success, C<$rc> is true. If an error occurs and the C callback returns, then only C<$dbh> will be passed and C<$@> contains the error message. =item $dbh->func ('string_which_yields_args_when_evaled', $func_name, $cb->($dbh, $rc, $dbi_err, $dbi_errstr)) This gives access to database driver private methods. Because they are not standard you cannot always depend on the value of C<$rc> or C<$dbi_err>. Check the documentation for your specific driver/function combination to see what it returns. Note that the first argument will be eval'ed to produce the argument list to the func() method. This must be done because the serialization protocol between the AnyEvent::DBI server process and your program does not support the passage of closures. Here's an example to extend the query language in SQLite so it supports an intstr() function: $cv = AnyEvent->condvar; $dbh->func ( q{ instr => 2, sub { my ($string, $search) = @_; return index $string, $search; }, }, create_function => sub { return $cv->send ($@) unless $#_; $cv->send (undef, @_[1,2,3]); } ); my ($err,$rc,$errcode,$errstr) = $cv->recv; die $err if defined $err; die "EVAL failed: $errstr" if $errcode; # otherwise, we can ignore $rc and $errcode for this particular func =cut for my $cmd_name (qw(exec attr begin_work commit rollback func)) { eval 'sub ' . $cmd_name . '{ my $cb = pop; splice @_, 1, 0, $cb, (caller)[1,2], "req_' . $cmd_name . '"; &_req }'; } =back =head1 SEE ALSO L, L, L. =head1 AUTHOR Marc Lehmann http://home.schmorp.de/ Adam Rosenstein http://www.redcondor.com/ =cut 1; AnyEvent-DBI-2.2/t/0000755000000000000000000000000011755057524012456 5ustar rootrootAnyEvent-DBI-2.2/t/myserver.conf0000644000000000000000000000363411211237020015161 0ustar rootrootmy $database = 'database'; my $table = 'table'; ( #{ # error => sub { get('username') ne 'myuser' ? "Access denied -- username must be 'myuser'." : undef }, #}, # # The queries below are sent by various connectors as part of connection establishment. # We provide canned answers for those # { command => DBIx::MyServer::COM_PING, ok => 1 }, { command => DBIx::MyServer::COM_INIT_DB, ok => 1 }, { match => 'SET SQL_AUTO_IS_NULL=0;', ok => 1 }, { match => 'set autocommit=1', ok => 1 }, { match => 'SELECT Config, nValue FROM MSysConf', error => ["MSysConf does not exist", 1146, '42S02'], }, { match => qr{^(select database|show databases)}sio, columns => 'Database', data => $database, }, { match => qr{^(show tables|show tables like '%')}io, columns => 'Tables_in_'.$database, data => $table, }, { match => "SHOW TABLES FROM `mysql` like '%'", columns => 'Tables_in_mysql (%)', data => ['user','host'], }, { match => qr{^show keys from}, columns => 'Keys', data => [], }, { match => qr{^select.*from\s+nosuchtable(\d*).*$}io, error => sub {[qq{Table '$database.nosuchtable$_[1]' doesn't exist},1146,'42S02']}, }, { match => qr{^select\s+(.*)\s+from(.*)$}io, columns => sub { if ($_[2]=~/delay(\d+)/) { sleep $1; } return [split(/,/,$_[1])], }, data => sub { my ($cmdline,$cols,$rest) = @_; my $numr=2; my $numc=scalar split(/,/,$cols); if ($rest=~/rows(\d+)/) { $numr=$1; } if ($rest=~/limit\s+(\d+)/i) { $numr = $numr > $1 ? $1 : $numr; } return [ ([ ('datum') x $numc ] ) x $numr ]; }, }, { match => qr{(.*)}o, error => 'not supported', }, ); AnyEvent-DBI-2.2/t/02_sql_lite.t0000644000000000000000000001706011221702655014752 0ustar rootroot#!/usr/bin/perl BEGIN { unless ($ENV{PERL_ANYEVENT_DBI_TESTS}) { print "1..0 # SKIP env var PERL_ANYEVENT_DBI_TESTS not set\n"; exit; } } use strict; use warnings; use AnyEvent; use AnyEvent::DBI; use File::Temp qw(tempfile); eval { require Test::More; import Test::More tests => 43; require DBD::SQLite; }; if ($@) { print 'ok 1 # skip - this test requires Test::More and DBD::SQLite'."\n"; exit 0; } # we are going to watch what the sub-processes send to stderr close STDERR; my($tfh_err,$tfn_err) = tempfile; close $tfh_err; open(STDERR,">>$tfn_err"); my ($cv,$dbh,$tfh,$tfn,$error,$result,$rv); ($tfh,$tfn) = tempfile; close $tfh; # connect with exec $cv = AnyEvent->condvar; $dbh = new AnyEvent::DBI( "dbi:SQLite:dbname=$tfn",'','', AutoCommit => 1, PrintError => 0, timeout => 2, exec_server => 1, on_error => sub { }, on_connect => sub {return $cv->send($@) unless $_[1]; $cv->send()}, ); $error = $cv->recv(); is($error,undef,'on_connect() called without error, sqlite server is connected'); # lets have an error $cv = AnyEvent->condvar; $dbh->exec('select bogus_column from no_such_table',sub {return $cv->send($@) unless $_[1];$cv->send(undef,$_[1])}); ($error,$result) = $cv->recv(); like ($error,qr{no such table}i,'Select from non existant table results in error'); # ensure we got no stderr output ok(-z $tfn_err,'Error does not result in output on STDERR'); # check the error behavior $cv = AnyEvent->condvar; $dbh->attr('PrintError',sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No errors occur while checking attribute'); ok(!$result,'Accessor without set (PrintError) returns false'); # change the error behavior $cv = AnyEvent->condvar; $dbh->attr(PrintError=>1,sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No error occurs while setting PrintError => 1'); ok($result,'Accessor with set (PrintError) returns true'); # check the error behavior $cv = AnyEvent->condvar; $dbh->attr('PrintError',sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No errors occur while checking attribute'); ok($result,'PrintError was true'); # lets have an error $cv = AnyEvent->condvar; $dbh->exec('select bogus_column from no_such_table',sub {return $cv->send($@) unless $_[1];$cv->send(undef,$_[1])}); ($error,$result) = $cv->recv(); like ($error,qr{no such table}i,'Select from non existant column makes an error'); # ensure we did get STDERR output ok(-s $tfn_err,'Error message has appeared on STDERR'); # create a table $cv = AnyEvent->condvar; $dbh->exec('create table a_table (a_column text)',sub {return $cv->send($@) unless $_[1];$cv->send(undef,$_[1])}); ($error,$result) = $cv->recv(); ok(!$error,'No errors creating a table'); # add some data $cv = AnyEvent->condvar; $dbh->exec('insert into a_table (a_column) values(?)','test',sub {return $cv->send($@) unless $#_;$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'No errors inserting into table'); is($rv,1,"One row affected"); # check for the data $cv = AnyEvent->condvar; $dbh->exec('select a_column from a_table',sub {return $cv->send($@) unless $#_;$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'No errors inserting into table'); ok($rv,'select succeeded'); is($result->[0]->[0],'test','found correct data'); # check the autocommit behavior $cv = AnyEvent->condvar; $dbh->attr('AutoCommit',sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No errors occur while checking attribute'); ok($result,'AutoCommit was true'); # turn off autocommit $cv = AnyEvent->condvar; $dbh->attr(AutoCommit=>0,sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No error setting attr'); ok(!$result,'AutoCommit was false'); # add some data $cv = AnyEvent->condvar; $dbh->exec('insert into a_table (a_column) values(?)','moredata',sub {return $cv->send($@) unless $#_;$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv; ok(!$error,'No errors inserting into table'); is($rv,1,"One row affected"); # crash the handle unlink $dbh; # connect without exec or autocommit $cv = AnyEvent->condvar; $dbh = new AnyEvent::DBI( "dbi:SQLite:dbname=$tfn",'','', AutoCommit => 0, PrintError => 0, timeout => 2, exec_server => 0, on_error => sub { }, on_connect => sub {return $cv->send($@) unless $_[1]; $cv->send()}, ); $error = $cv->recv(); is($error,undef,'on_connect() called without error, sqlite server is connected'); # check for the data and that the aborted transaction did not make it to the database $cv = AnyEvent->condvar; $dbh->exec('select a_column from a_table',sub {return $cv->send($@) unless $_[1];$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'No errors selecting from table'); ok($rv,'select succeeded'); is(scalar @$result,1,'found only one row'); is($result->[0]->[0],'test','found correct data in that row'); # add some data $cv = AnyEvent->condvar; $dbh->exec('insert into a_table (a_column) values(?)','moredata',sub {return $cv->send($@) unless $#_;$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'No errors inserting into table'); is($rv,1,'One row affected'); # commit to db $cv = AnyEvent->condvar; $dbh->commit(sub {return $cv->send($@) unless $_[1];$cv->send(undef,$_[1])}); ($error,$result) = $cv->recv(); ok(!$error,'No errors commiting'); # check for the data and that the aborted transaction did not make it to the database $cv = AnyEvent->condvar; $dbh->exec('select a_column from a_table',sub {return $cv->send($@) unless $_[1];$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'No errors inserting into table'); ok($rv,'select succeeded'); is(scalar @$result,2,'found two rows'); is($result->[0]->[0],'test','found correct data in row one'); is($result->[1]->[0],'moredata','found correct data in row two'); # change the autocommit behavior $cv = AnyEvent->condvar; $dbh->attr(AutoCommit=>1,sub {return $cv->send($@) unless $_[1]; $cv->send(undef,$_[1])}); ($error,$result)= $cv->recv(); ok(!$error,'No error occurs while setting AutoCommit => 1'); ok($result,'Accessor with set (AutoCommit) returns true'); # using bad function returns error $cv = AnyEvent->condvar; #$dbh->exec('select a_column from a_table where instr(a_column,?)','re',sub {return $cv->send($@) unless $_[0];$cv->send(undef,@_[1,2]);}); $dbh->exec('select a_column from a_table where instr(a_column,?)','re', sub {return $cv->send($@,@_[0,1,2]);}); my $hdl; ($error,$hdl,$result,$rv) = $cv->recv(); like($error,qr{function}i,'Using an unknown function results in error'); # create the function $cv = AnyEvent->condvar; $dbh->func( q{ 'instr', 2, sub { my ($string, $search) = @_; return index $string, $search; }, }, 'create_function', sub {return $cv->send($@) unless $_[1];$cv->send(undef,$_[1])} ); $cv->recv(); # ignore result from this particular private fn. # using new function $cv = AnyEvent->condvar; $dbh->exec('select a_column from a_table where instr(a_column,?) >= 0','re',sub {return $cv->send($@) unless $_[1];$cv->send(undef,@_[1,2])}); ($error,$result,$rv) = $cv->recv(); ok(!$error,'Our new function works fine'); ok($rv,'select succeeded'); is(scalar @$result,1,'found only one row'); is($result->[0]->[0],'moredata','found correct data'); END { unlink $tfn if $tfn; # system ("cat $tfn_err"); unlink $tfn_err if $tfn_err; } AnyEvent-DBI-2.2/t/fake-mysql0000644000000000000000000005301111211237020014424 0ustar rootroot#!/usr/bin/perl =pod =head1 SYNOPSIS perl examples/myserver.pl --config=examples/myserver.conf --port=1234 --dsn="dbi:mysql:" mysql -h127.0.0.1 -P1234 -umyuser -e 'info' =head1 DESCRIPTION This is a simple server that listens for incoming connections from MySQL clients or connectors. Each query received is processed according to a set of configuration files, which can rewrite the query, forward it to a DBI handle or construct a response or a result set on the fly from any data. =head1 COMMAND LINE OPTIONS C<--port=XXXX> - port to listen on. Default is C<23306>, which is the default MySQL port with a 2 in front. C<--interface=AAA.BBB.CCC.DDD> - interface to listen to. Default is C<127.0.0.1> which means that only connections from the localhost will be accepted. To enable connections from the outside use C<--interface=0.0.0.0>. In this case, please make sure you have some other form of access protection, e.g. like the first rule in the C example configuration file. C<--config=config.file> - a configuration file containing rules to be executed. The option can be specified multiple times and the rules will be checked in the order specified. C<--dsn> - specifies a L DSN. All queries that did not match a rule or where the rule rewrote the query or did not return any response or a result set on its own will be forwarded to that database. Individual rules can forward specific queries to specific DSNs. If you do not want non-matching queries to be forwarded, either create a match-all rule at the bottom of your last configuration file or omit the C<--dsn> option. If you omit the option, an error message will be sent to the client. C<--dsn_user> and C<--dsn_password> can be used to specify username and password for DBI drivers where those can not be specified in the DSN string. =head1 RULES Rules to be executed are contained in configuration files. The configuration files are actually standard perl scripts and are executed as perl subroutines. Therefore, they can contain any perl code -- the only requirement is that the last statement in the file (that is, the return value of the file) is an array containing the rules to be executed. The actions from a rule will be executed for all queries that match a specific pattern. Rules are processed in order and processing is terminated at the first rule that returns some data to the client. This allows you to rewrite a query numerous times and have a final default rule that forwards the query to another server. If C is defined, further rules are not processed. Each rule can have the following attributes: C The rule will match if the MySQL command issued by the client matches C. C can either be an integer from the list found at C or a reference to a C that returns such an integer. This is mainly useful for processing incoming C, C and C. C The rule will match if the test of the query matches a regular expression or is identical to a string. C can also be a reference to a C in which case the sub is executed and can either return a string or a regular expression. If both C and C are specified, both must match for the rule to be executed. C if specified, any matching query will be forwarded to this database handle (possibly after a C), rather than the default handle specifeid on the command line. C behaves identically, however a database handle is contructed from the C provided and an attempt is made to connect to the database. If C is a reference to an array, the first item from the array is used as a DSN, the second one is used as username and the third one is used as password. C this can be a reference to a subroutine that will be called after a matching query has been encountered but before any further processing has taken place. The subroutine will be called with the text of the query as the first argument, followed by extra arguments containing the strings matched from any parenthesis found in the C regular expression. You can use C to execute any extra queries before the main query, such as C. The return value from the C subroutine is discarded and is not used. C is a string that will replace the original query that matches the rule, or a reference to a subroutine that will produce such a string. If C is not defined, and C was a string, the query is passed along unchanged. If C was a regular expression, the string matched by the first set of parenthesis is used. This way, if the rule does not specify any C, C, C or C clauses, but a valid DBI handle is defined, the query will be forwarded to that handle automatically. C can be either an array reference containing three arguments for C or a reference to a subroutine returning such an array (or array reference). If this is the case, the error message will be sent to the client. If C is not defined or the subroutine returns C, no error message will be sent. In this case, you need to send at some point either an C or a result set, otherwise the client will hang forever waiting for a response. C behaves identically to C -- if it is defined or points to a subroutine which, when called, returns a true value, an OK response will be sent to the client. C can also be a reference to an array, or the subroutine can return such an array -- in this case the first item is the message to be sent to the client, the second one is the number of affected rows, the third is the insert_id and the last one is the warning count. C must contain either an array reference or a reference to a subroutine which returns and array or array reference. The column names from the array will be sent to the client. By default, all columns are defined as C. C must contain either a reference to the data to be returned to the client or a reference to subroutine that will produce the data. "Data" can be a reference to a C, in which case the hash will be sent with the key names in the first column and the key values in the second. It can be a flat array, in which case the array items will be sent as a single column, or it can be a reference to a nested array, with each sub-array being a single row from the response. C is called after all other parts of the rule have been processed. C if defined, the query will be immediately forwarded to the server and no further rules will be processed. All subroutine references that are called will have the text of the query passed as the first argument and the subsequent arguments will be any strings matched by parenthesis in the C regular expression. =head1 VARIABLES Your code in the configuration file can save and retrieve state by using C and C. State is retained as long as the connection is open. Each new connection starts with a clean state. The following variables are maintained by the system: C contains a reference to the L object being used to service the connection. You can use this to inject data and packets directly into the network stream. C contains the username provided by the client at connection establishment. C contains the database requested by the client at connection establishment. By default, C will not automatically handle any database changes requested by the client. You are responsible for handling those either by responding with a simple OK or by updating the variables. C contains the IP of the client. C and C will contain a reference to the default DBI handle and the DSN string it was produced from, as taken from the command line. Even if a specific rule has its own C, the value of those variables will always refer to the default C and C. If you change the variable, the system will attempt to connect to the new dsn string and will produce a new C handle from it. If you set C to an array reference, the first item will be used as a DSN, the second one as a username and the third one as a password. C and C can be used for the same purpose. C contains a reference to the C<@ARGV> array, that is, the command line options that evoked myserver.pl C, C and C are convenience variables that can also be specified on the command line. It is not used by C however you can use it in your rules, the way C does. =head1 SECURITY By default the script will only accept incoming connections from the local host. If you relax that via the C<--interface> command-line option, all connections will be accepted. However, once the connection has been established, you can implement access control as demonstrated in the first rule of the C file -- it returns "Access denied" for every query unless the username is "myuser". Future versions of the script will allow connections to be rejected during handshake. =head1 SAMPLE RULES The following rule sets are provided in the C directory. =head2 Simple examples - myserver.conf This configuration provides some simple query rewriting examples as suggested by Giuseppe Maxia and Jan Kneschke, e.g. commands like C, C as well as fixing spelling mistakes. In addition, some very simple access control is demonstrated at the top of the file. =head2 Remote queries - remotequery.conf This rule set implements a C