WIP: fix issues 1106, 1107, and 1185

docs/about/changelog.md

@@ -4,6 +4,9 @@ Release history of PerlOnJava. See [Roadmap](roadmap.md) for future plans.
 
 ## Work in progress
 
+* Add JDBC-backed `DBD::mysql` and `DBD::Pg` compatibility shims and preserve
+  SQLite URI-file schema state across DBI connections.
+
 - Parse fully-qualified indirect constructors followed by method calls, and
   stage generated nested pure-Perl MakeMaker modules correctly (including
   NetAddr::IP's `-noxs` installation path).

src/main/perl/lib/DBD/JDBC.pm

@@ -17,21 +17,21 @@ use warnings;
 
 our $VERSION = '0.01';
 
-our $drh = undef;
+our %drh;
 
 sub driver {
     my ($class, $attr) = @_;
-    return $drh if $drh;
+    return $drh{$class} if $drh{$class};
 
-    ($drh) = DBI::_new_drh("${class}::dr", {
+    ($drh{$class}) = DBI::_new_drh("${class}::dr", {
         Name        => ($class =~ /^DBD::(\w+)/)[0] || 'JDBC',
         Version     => $VERSION,
         Attribution => "$class via JDBC (PerlOnJava)",
     });
-    return $drh;
+    return $drh{$class};
 }
 
-sub CLONE { undef $drh; }
+sub CLONE { %drh = (); }
 
 # ---------------------------------------------------------------------
 package DBD::JDBC::dr;

src/main/perl/lib/DBD/Pg.pm

@@ -0,0 +1,90 @@
+package DBD::Pg;
+
+use strict;
+use warnings;
+
+our $VERSION = '3.18.0';
+our $drh;
+
+# PerlOnJava compatibility shim for DBD::Pg.  The actual connection and
+# statement operations are supplied by the in-JVM JDBC implementation; this
+# module only adapts DBI's PostgreSQL DSN syntax to a PostgreSQL JDBC URL.
+use DBI ();
+use DBD::JDBC ();
+our @ISA = ('DBD::JDBC');
+
+{
+    package DBD::Pg::dr;
+    our @ISA = ('DBD::JDBC::dr');
+
+    sub connect {
+        my ($drh, $dsn_rest, $user, $pass, $attr) = @_;
+        my $jdbc_url = DBD::Pg->_dsn_to_jdbc($dsn_rest);
+        my $dbh = DBD::JDBC::dr::connect($drh, $jdbc_url, $user, $pass, $attr);
+        if ($dbh) {
+            $dbh = bless $dbh, 'DBD::Pg::db';
+            $dbh->{Driver} = $drh;
+        }
+        return $dbh;
+    }
+}
+
+{
+    package DBD::Pg::db;
+    our @ISA = ('DBD::JDBC::db');
+}
+
+{
+    package DBD::Pg::st;
+    our @ISA = ('DBD::JDBC::st');
+}
+
+# Translate the libpq-style key/value DSN accepted by DBD::Pg.  The JDBC
+# driver uses URL query parameters for the same connection properties.
+sub _dsn_to_jdbc {
+    my ($class, $dsn_rest) = @_;
+    $dsn_rest = '' unless defined $dsn_rest;
+
+    # Also accept the short DBD::Pg form, e.g. "mydb".
+    if ($dsn_rest !~ /=/) {
+        return "jdbc:postgresql://localhost/$dsn_rest";
+    }
+
+    my (%values, @options);
+    for my $part (split /;/, $dsn_rest) {
+        next unless $part =~ /^\s*([^=\s]+)\s*=\s*(.*?)\s*$/s;
+        my ($key, $value) = (lc($1), $2);
+        if ($key eq 'dbname' || $key eq 'database') {
+            $values{dbname} = $value;
+        } elsif ($key eq 'host' || $key eq 'port') {
+            $values{$key} = $value;
+        } elsif ($key ne 'user' && $key ne 'password') {
+            # JDBC accepts PostgreSQL driver properties as URL parameters.
+            push @options, $key . '=' . $value;
+        }
+    }
+
+    my $host = length($values{host} // '') ? $values{host} : 'localhost';
+    my $port = length($values{port} // '') ? ':' . $values{port} : '';
+    my $dbname = $values{dbname} // '';
+    my $url = "jdbc:postgresql://$host$port/$dbname";
+    $url .= '?' . join('&', @options) if @options;
+    return $url;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBD::Pg - PerlOnJava PostgreSQL driver via JDBC
+
+=head1 DESCRIPTION
+
+This is a PerlOnJava compatibility shim.  It preserves the DBD::Pg DBI DSN
+interface and delegates database operations to the PostgreSQL JDBC driver,
+which must be supplied on the PerlOnJava classpath or selected with
+C<Configure.pl>.
+
+=cut

src/main/perl/lib/DBD/SQLite.pm

@@ -69,11 +69,17 @@ our @ISA = ('DBD::JDBC');
 #   dbname=/path/to/db    -> jdbc:sqlite:/path/to/db
 #   /path/to/db           -> jdbc:sqlite:/path/to/db
 #   dbname=file.db        -> jdbc:sqlite:file.db
+#   uri=file:/path/to/db  -> jdbc:sqlite:file:/path/to/db
 sub _dsn_to_jdbc {
     my ($class, $dsn_rest) = @_;
 
     my $dbname;
-    if ($dsn_rest =~ /(?:^|;)dbname=(.+?)(?:;|$)/) {
+    if ($dsn_rest =~ /(?:^|;)uri=(.+?)(?:;|$)/i) {
+        # DBD::SQLite's URI filename form is an explicit `uri=` DSN
+        # component. Preserve the complete file URI, including its query
+        # parameters (for example mode=rwc or cache=shared), for SQLite JDBC.
+        $dbname = $1;
+    } elsif ($dsn_rest =~ /(?:^|;)dbname=(.+?)(?:;|$)/) {
         $dbname = $1;
     } elsif ($dsn_rest =~ /(?:^|;)database=(.+?)(?:;|$)/i) {
         $dbname = $1;

src/main/perl/lib/DBD/mysql.pm

@@ -0,0 +1,95 @@
+package DBD::mysql;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.013';
+
+# PerlOnJava's MySQL driver is the ordinary DBI/JDBC implementation with a
+# DBD::mysql-compatible DSN and handle namespace.  The MySQL JDBC driver is
+# supplied separately through Configure.pl or CLASSPATH; this shim deliberately
+# does not add a driver dependency to the runtime.
+use DBI ();
+use DBD::JDBC ();
+our @ISA = ('DBD::JDBC');
+
+{
+    package DBD::mysql::dr;
+    our @ISA = ('DBD::JDBC::dr');
+
+    sub connect {
+        my ($drh, $dsn_rest, $user, $pass, $attr) = @_;
+        my $jdbc_url = DBD::mysql->_dsn_to_jdbc($dsn_rest);
+        my $dbh = DBD::JDBC::dr::connect($drh, $jdbc_url, $user, $pass, $attr);
+        if ($dbh) {
+            $dbh = bless $dbh, 'DBD::mysql::db';
+            $dbh->{Driver} = $drh;
+        }
+        return $dbh;
+    }
+}
+
+{
+    package DBD::mysql::db;
+    our @ISA = ('DBD::JDBC::db');
+}
+
+{
+    package DBD::mysql::st;
+    our @ISA = ('DBD::JDBC::st');
+}
+
+# Translate the conventional DBD::mysql DSN suffix to a MySQL JDBC URL.
+# Supported forms include:
+#   database=test;host=db.example;port=3307
+#   test;host=db.example
+#   host=db.example;database=test
+# A bare suffix is treated as the database name, matching DBD::mysql.
+sub _dsn_to_jdbc {
+    my ($class, $dsn_rest) = @_;
+    $dsn_rest = '' unless defined $dsn_rest;
+
+    # This is useful for callers that already use a JDBC URL with the mysql
+    # driver name and keeps the mapping harmless for DBI-compatible wrappers.
+    return $dsn_rest if $dsn_rest =~ /^jdbc:mysql:/i;
+
+    my ($database, $host, $port);
+    my @parts = split /;/, $dsn_rest, -1;
+    for my $part (@parts) {
+        next unless length $part;
+        if ($part =~ /^([^=]+)=(.*)$/) {
+            my ($key, $value) = (lc $1, $2);
+            $database = $value if $key eq 'database' || $key eq 'dbname';
+            $host = $value if $key eq 'host' || $key eq 'hostname';
+            $port = $value if $key eq 'port';
+        } elsif (!defined $database) {
+            $database = $part;
+        }
+    }
+
+    $database = '' unless defined $database;
+    $host = 'localhost' unless defined $host && length $host;
+    $port = 3306 unless defined $port && length $port;
+
+    my $url = "jdbc:mysql://$host:$port/$database";
+    return $url;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBD::mysql - PerlOnJava MySQL driver via JDBC
+
+=head1 DESCRIPTION
+
+This is a PerlOnJava compatibility shim for C<DBD::mysql>.  It translates
+the standard DBI MySQL DSN to a JDBC URL and delegates database operations to
+the bundled C<DBD::JDBC> implementation.
+
+The MySQL JDBC driver is not bundled.  Add one with C<Configure.pl> or place
+its JAR on C<CLASSPATH> before running PerlOnJava.
+
+=cut

src/main/perl/lib/DBI.pm

@@ -597,7 +597,7 @@ sub _is_jdbc_handle {
     return 1 if ref($handle) =~ /^DBI::(?:db|st)$/
         && !defined $handle->{ImplementorClass};
     my $impl = $handle->{ImplementorClass} || ref($handle);
-    return $impl =~ /^DBD::(?:JDBC|SQLite)::/;
+    return $impl =~ /^DBD::(?:JDBC|SQLite|Pg|mysql)::/;
 }
 
 sub _apply_root_class {

src/test/resources/unit/dbd_mysql_shim.t

@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    eval { require DBD::mysql; 1 }
+        or plan skip_all => 'DBD::mysql shim unavailable';
+}
+
+is(
+    DBD::mysql->_dsn_to_jdbc('database=orders;host=db.example;port=3307'),
+    'jdbc:mysql://db.example:3307/orders',
+    'maps named MySQL DSN attributes',
+);
+is(
+    DBD::mysql->_dsn_to_jdbc('orders;host=db.example'),
+    'jdbc:mysql://db.example:3306/orders',
+    'maps positional database and default port',
+);
+is(
+    DBD::mysql->_dsn_to_jdbc('host=db.example;dbname=orders'),
+    'jdbc:mysql://db.example:3306/orders',
+    'accepts dbname after host',
+);
+is(
+    DBD::mysql->_dsn_to_jdbc(''),
+    'jdbc:mysql://localhost:3306/',
+    'uses MySQL defaults for an empty suffix',
+);
+is(
+    DBD::mysql->_dsn_to_jdbc('jdbc:mysql://db.example/orders'),
+    'jdbc:mysql://db.example/orders',
+    'preserves an explicit JDBC URL',
+);
+
+ok(DBD::mysql->isa('DBD::JDBC'), 'driver inherits from DBD::JDBC');
+ok(DBD::mysql::dr->isa('DBD::JDBC::dr'), 'database driver inherits JDBC driver');
+ok(DBD::mysql::db->isa('DBD::JDBC::db'), 'database handle inherits JDBC handle');
+ok(DBD::mysql::st->isa('DBD::JDBC::st'), 'statement handle inherits JDBC statement');
+
+done_testing;

src/test/resources/unit/dbd_pg.t

@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    eval { require DBD::Pg; 1 }
+        or plan skip_all => 'DBD::Pg is not available';
+}
+
+is(
+    DBD::Pg->_dsn_to_jdbc('dbname=app;host=db.example;port=5433'),
+    'jdbc:postgresql://db.example:5433/app',
+    'translates a standard PostgreSQL DSN',
+);
+is(
+    DBD::Pg->_dsn_to_jdbc('database=app;sslmode=require;connect_timeout=5'),
+    'jdbc:postgresql://localhost/app?sslmode=require&connect_timeout=5',
+    'translates aliases and JDBC connection properties',
+);
+is(
+    DBD::Pg->_dsn_to_jdbc('app'),
+    'jdbc:postgresql://localhost/app',
+    'translates the short database-name form',
+);
+ok(DBD::Pg::dr->isa('DBD::JDBC::dr'), 'driver handle inherits JDBC backend');
+ok(DBD::Pg::db->isa('DBD::JDBC::db'), 'database handle inherits JDBC backend');
+ok(DBD::Pg::st->isa('DBD::JDBC::st'), 'statement handle inherits JDBC backend');
+
+done_testing;

src/test/resources/unit/dbi_sqlite_uri_connections.t

@@ -0,0 +1,55 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use File::Temp qw(tempfile);
+use DBI;
+
+eval { require DBD::SQLite; 1 }
+    or plan skip_all => 'DBD::SQLite required';
+
+plan tests => 4;
+
+my ($file_a, $path_a) = tempfile(SUFFIX => '.sqlite');
+close $file_a;
+unlink $path_a;
+my ($file_b, $path_b) = tempfile(SUFFIX => '.sqlite');
+close $file_b;
+unlink $path_b;
+
+my $dsn_a = "dbi:SQLite:uri=file:$path_a?mode=rwc";
+my $dsn_b = "dbi:SQLite:uri=file:$path_b?mode=rwc";
+
+my $dbh = DBI->connect($dsn_a, '', '', {
+    RaiseError => 1,
+    PrintError => 0,
+});
+$dbh->do('create table uri_schema (value integer)');
+$dbh->do('insert into uri_schema values (1185)');
+$dbh->disconnect;
+
+$dbh = DBI->connect($dsn_a, '', '', {
+    RaiseError => 1,
+    PrintError => 0,
+});
+my ($value) = $dbh->selectrow_array('select value from uri_schema');
+is($value, 1185, 'URI file database keeps its schema across connections');
+$dbh->disconnect;
+
+my $other = DBI->connect($dsn_b, '', '', {
+    RaiseError => 1,
+    PrintError => 0,
+});
+my $has_schema = eval {
+    $other->selectrow_array('select value from uri_schema');
+    1;
+};
+ok(!$has_schema, 'a distinct URI file DSN has an isolated schema');
+$other->do('create table uri_schema (value integer)');
+$other->do('insert into uri_schema values (2206)');
+my ($other_value) = $other->selectrow_array('select value from uri_schema');
+is($other_value, 2206, 'distinct URI file database remains usable');
+$other->disconnect;
+
+ok(unlink($path_a) && unlink($path_b), 'temporary URI databases are removed');