The following patch implements the new DBI feature take_imp_data, which is needed for DBI::Pool (threaded database pooling module) to work. You will need to use the latest DBI svn for the following to work:
svn co https://svn.perl.org/modules/dbi/trunk DBI
It also includes a new test:
Index: dbdimp.c =================================================================== RCS file: /home/stas/cvs/modules/DBD-mysql/dbdimp.c,v retrieving revision 1.1 diff -u -r1.1 dbdimp.c --- dbdimp.c 23 Mar 2005 23:07:00 -0000 1.1 +++ dbdimp.c 6 Apr 2005 23:26:41 -0000 @@ -988,6 +988,19 @@ char* unixSocket = NULL; STRLEN len, lna;
+ if (DBIc_has(imp_dbh, DBIcf_IMPSET)) { /* eg from take_imp_data() */
+ if (DBIc_has(imp_dbh, DBIcf_ACTIVE)) {
+ if (dbis->debug >= 2)
+ PerlIO_printf(DBILOGFP, "_MyLogin skip connect\n");
+ /* tell our parent we've adopted an active child */
+ ++DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_dbh));
+ return TRUE;
+ }
+ if (dbis->debug >= 2)
+ PerlIO_printf(DBILOGFP,
+ "_MyLogin IMPSET but not ACTIVE so connect not skipped\n");
+ }
+
sv = DBIc_IMP_DATA(imp_dbh);
if (!sv || !SvROK(sv)) {
return FALSE;
Index: lib/DBD/mysql.pm
===================================================================
RCS file: /home/stas/cvs/modules/DBD-mysql/lib/DBD/mysql.pm,v
retrieving revision 1.1
diff -u -r1.1 mysql.pm
--- lib/DBD/mysql.pm 23 Mar 2005 23:07:01 -0000 1.1
+++ lib/DBD/mysql.pm 6 Apr 2005 23:26:41 -0000
@@ -119,7 +119,10 @@
DBD::mysql->_OdbcParse($dsn, $privateAttrHash,
['database', 'host', 'port']);
- if (!defined($this = DBI::_new_dbh($drh, {'Name' => $dsn},
+ my $dbi_imp_data = delete $attrhash->{dbi_imp_data};
+ if (!defined($this = DBI::_new_dbh($drh,
+ {'Name' => $dsn,
+ 'dbi_imp_data' => $dbi_imp_data },
$privateAttrHash))) {
return undef;
}
--- /dev/null 2005-03-22 13:01:45.030128280 -0500
+++ t/70takeimp.t 2005-04-06 19:26:35.000000000 -0400
@@ -0,0 +1,174 @@
+#!/usr/local/bin/perl
+#
+# $Id: 70takeimp.t,v 1.1 2005/03/23 23:07:04 stas Exp $
+#
+# This is a skeleton test. For writing new tests, take this file
+# and modify/extend it.
+#
+
+use strict;
+use vars qw($test_dsn $test_user $test_password $mdriver $dbdriver);
+use DBI ();
+
+#
+# Include lib.pl
+#
+$mdriver = "";
+my $file;
+foreach $file ("lib.pl", "t/lib.pl") {
+ do $file; if ($@) { print STDERR "Error while executing lib.pl: [EMAIL PROTECTED]";
+ exit 10;
+ }
+ if ($mdriver ne '') {
+ last;
+ }
+}
+
+my $drh = DBI->install_driver($mdriver);
+
+sub ServerError() {
+ print STDERR ("Cannot connect: ", $DBI::errstr, "\n",
+ "\tEither your server is not up and running or you have no\n",
+ "\tpermissions for acessing the DSN $test_dsn.\n",
+ "\tThis test requires a running server and write permissions.\n",
+ "\tPlease make sure your server is running and you have\n",
+ "\tpermissions, then retry.\n");
+ exit 10;
+}
+
+#DBI->trace(1);
+
+#
+# Main loop; leave this untouched, put tests into the loop
+#
+use vars qw($state);
+while (Testing()) {
+ #
+ # Connect to the database
+ my $dbh;
+ Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password))
+ or ServerError();
+
+ my $id = connection_id($dbh);
+ print "Initial connection: $id\n";
+
+ my $drh = $dbh->{Driver};
+
+ my $imp_data;
+ Test($state or $imp_data = $dbh->take_imp_data)
+ or ErrMsg("didn't get imp_data");
+
+ Test($state or length($imp_data) >= 80)
+ or ErrMsg('test that our imp_data is greater than or equal to 80, this is reasonable');
+
+ Test($state or $drh->{Kids} == 0)
+ or ErrMsg('our Driver should have 0 Kid(s) after calling take_imp_data');
+
+ {
+ my $warn;
+ local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /after take_imp_data/ };
+
+ my $drh = $dbh->{Driver};
+ Test($state or !defined $drh)
+ or ErrMsg('... our Driver should be undefined');
+
+ my $trace_level = $dbh->{TraceLevel};
+ Test($state or !defined $trace_level)
+ or ErrMsg('our TraceLevel should be undefined');
+
+ Test($state or !defined $dbh->disconnect)
+ or ErrMsg('disconnect should return undef');
+
+ Test($state or !defined $dbh->quote(42))
+ or ErrMsg('quote should return undefined');
+
+ Test($state or $warn == 4)
+ or ErrMsg('we should have gotten 4 warnings');
+ }
+
+ # XXX: how can we test that the connection wasn't actually dropped?
+
+ #use Data::Dumper;
+ #print "GOT $imp_data\n";
+ warn "re-CONNECT\n";
+
+ my $dbh2 = DBI->connect($test_dsn, $test_user, $test_password, { dbi_imp_data => $imp_data });
+ #my $dbh2 = DBI->connect($test_dsn, $test_user, $test_password);
+
+ # XXX: how can we test that the same connection is used?
+ my $id2 = connection_id($dbh2);
+ print "Overridden connection: $id2\n";
+
+ Test($state or $id == $id2)
+ or ErrMsg("the same connection: $id => $id2\n");
+
+ my $drh2;
+ Test($state or $drh2 = $dbh2->{Driver})
+ or ErrMsg("can't get the driver\n");
+
+ Test($state or $dbh2->isa("DBI::db"))
+ or ErrMsg('isa test');
+ # need a way to test dbi_imp_data has been used
+
+ Test($state or $drh2->{Kids} == 1)
+ or ErrMsg("our Driver should have 1 Kid(s) again: having " . $drh2->{Kids} . "\n");
+
+ Test($state or $drh2->{ActiveKids} == 1)
+ or ErrMsg("our Driver should have 1 ActiveKid again: having " . $drh2->{ActiveKids} . "\n");
+
+ read_write_test($dbh2);
+
+ # must cut the connection data again
+ Test($state or $imp_data = $dbh2->take_imp_data)
+ or ErrMsg("didn't get imp_data");
+
+ #
+ # Finally disconnect.
+ #
+ #Test($state or $dbh2->disconnect())
+ #or DbiError($dbh2->err, $dbh2->errstr);
+
+}
+
+sub read_write_test {
+ my $dbh = shift;
+
+ # now the actual test:
+
+ # Find a possible new table name
+ #
+ my $table;
+ Test($state or $table = FindNewTable($dbh))
+ or DbiError($dbh->err, $dbh->errstr);
+
+ #
+ # Create a new table
+ #
+ my $def;
+ if (!$state) {
+ ($def = TableDefinition($table,
+ ["id", "INTEGER", 4, 0],
+ ["name", "CHAR", 64, 0]));
+ print "Creating table:\n$def\n";
+ }
+ Test($state or $dbh->do($def))
+ or DbiError($dbh->err, $dbh->errstr);
+
+ #
+ # ... and drop it.
+ #
+ Test($state or $dbh->do("DROP TABLE $table"))
+ or DbiError($dbh->err, $dbh->errstr);
+
+}
+
+sub connection_id {
+ my $dbh = shift;
+ return 0 unless $dbh;
+
+ # Paul DuBois says the following is more reliable than
+ # $dbh->{'mysql_thread_id'};
+ my @row = $dbh->selectrow_array("SELECT CONNECTION_ID()");
+
+ return $row[0];
+}
Everything is fine, but if the end of the test doesn't call take_imp_data again, but calls disconnect as in:
# must cut the connection data again
#Test($state or $imp_data = $dbh2->take_imp_data)
# or ErrMsg("didn't get imp_data"); #
# Finally disconnect.
#
Test($state or $dbh2->disconnect())
or DbiError($dbh2->err, $dbh2->errstr);we get a segfault:
#0 0xffffe410 in ?? ()
(gdb) bt
#0 0xffffe410 in ?? ()
#1 0xbfffcf64 in ?? ()
#2 0x00000006 in ?? ()
#3 0x000040b1 in ?? ()
#4 0xb7cf16e5 in raise () from /lib/tls/libc.so.6
#5 0xb7cf3049 in abort () from /lib/tls/libc.so.6
#6 0xb7d2579a in __fsetlocking () from /lib/tls/libc.so.6
#7 0xb7d2bd7c in malloc_trim () from /lib/tls/libc.so.6
#8 0xb7d2c35a in free () from /lib/tls/libc.so.6
#9 0xb7b43451 in my_no_flags_free () from /usr/lib/libmysqlclient.so.14
#10 0xb7b66d3d in vio_delete () from /usr/lib/libmysqlclient.so.14
#11 0xb7b61ed4 in end_server () from /usr/lib/libmysqlclient.so.14
#12 0xb7b64fac in cli_advanced_command () from /usr/lib/libmysqlclient.so.14
#13 0xb7b63642 in mysql_close () from /usr/lib/libmysqlclient.so.14
#14 0xb7b635e6 in mysql_close () from /usr/lib/libmysqlclient.so.14
#15 0xb7c3d502 in mysql_db_disconnect (dbh=0x8246f68, imp_dbh=0x8247ea0)
at dbdimp.c:1204
#16 0xb7c44cd3 in XS_DBD__mysql__db_disconnect (my_perl=0x804c008, cv=0x822eac4)
at mysql.xsi:286
#17 0xb7c63932 in XS_DBI_dispatch (my_perl=0x804c008, cv=0x81ecb18) at DBI.xs:2707
#18 0xb7f2c5a5 in Perl_pp_entersub (my_perl=0x804c008) at pp_hot.c:2890
#19 0xb7f089a9 in Perl_runops_debug (my_perl=0x804c008) at dump.c:1449
#20 0xb7eace30 in S_run_body (my_perl=0x804c008, oldscope=1) at perl.c:1934
#21 0xb7eac870 in perl_run (my_perl=0x804c008) at perl.c:1853
#22 0x080494c6 in main (argc=3, argv=0xbfffda14, env=0xbfffda24) at perlmain.c:98
Looking at mysql source it tries to destroy other entries in the record using the same function:
void STDCALL mysql_close(MYSQL *mysql)
{
DBUG_ENTER("mysql_close");
if (mysql) /* Some simple safety */
{
[...]
if (mysql->rpl_pivot)
{
MYSQL* tmp;
for (tmp = mysql->next_slave; tmp != mysql; )
{
/* trick to avoid following freed pointer */
MYSQL* tmp1 = tmp->next_slave;
====> mysql_close(tmp);
tmp = tmp1;
}
mysql->rpl_pivot=0;
}
#endif
if (mysql != mysql->master)
=====> mysql_close(mysql->master);Any ideas?
-- __________________________________________________________________ Stas Bekman JAm_pH ------> Just Another mod_perl Hacker http://stason.org/ mod_perl Guide ---> http://perl.apache.org mailto:[EMAIL PROTECTED] http://use.perl.org http://apacheweek.com http://modperlbook.org http://apache.org http://ticketmaster.com
