diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 5a64ae7810..37eeadf402 100644 --- a/docs/about/changelog.md +++ b/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). diff --git a/src/main/perl/lib/DBD/JDBC.pm b/src/main/perl/lib/DBD/JDBC.pm index f5c893aaa6..937013e3ce 100644 --- a/src/main/perl/lib/DBD/JDBC.pm +++ b/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; diff --git a/src/main/perl/lib/DBD/Pg.pm b/src/main/perl/lib/DBD/Pg.pm new file mode 100644 index 0000000000..ca30c48eba --- /dev/null +++ b/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. + +=cut diff --git a/src/main/perl/lib/DBD/SQLite.pm b/src/main/perl/lib/DBD/SQLite.pm index 0fa5120379..3bac026f9b 100644 --- a/src/main/perl/lib/DBD/SQLite.pm +++ b/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; diff --git a/src/main/perl/lib/DBD/mysql.pm b/src/main/perl/lib/DBD/mysql.pm new file mode 100644 index 0000000000..f382a9f163 --- /dev/null +++ b/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. It translates +the standard DBI MySQL DSN to a JDBC URL and delegates database operations to +the bundled C implementation. + +The MySQL JDBC driver is not bundled. Add one with C or place +its JAR on C before running PerlOnJava. + +=cut diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index 92aeb4610a..0ab87b4051 100644 --- a/src/main/perl/lib/DBI.pm +++ b/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 { diff --git a/src/test/resources/unit/dbd_mysql_shim.t b/src/test/resources/unit/dbd_mysql_shim.t new file mode 100644 index 0000000000..21c4197147 --- /dev/null +++ b/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; diff --git a/src/test/resources/unit/dbd_pg.t b/src/test/resources/unit/dbd_pg.t new file mode 100644 index 0000000000..d7d6a9db13 --- /dev/null +++ b/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; diff --git a/src/test/resources/unit/dbi_sqlite_uri_connections.t b/src/test/resources/unit/dbi_sqlite_uri_connections.t new file mode 100644 index 0000000000..25cbdd5cc5 --- /dev/null +++ b/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');