implemented ping and db_filename to resolve #64177

SQLite.xs

@@ -237,6 +237,15 @@ table_column_metadata(dbh, dbname, tablename, columnname)
     OUTPUT:
         RETVAL
 
+SV*
+db_filename(dbh)
+    SV* dbh
+    ALIAS:
+        DBD::SQLite::db::sqlite_db_filename = 1
+    CODE:
+        RETVAL = sqlite_db_filename(aTHX_ dbh);
+    OUTPUT:
+        RETVAL
 
 static int
 register_fts3_perl_tokenizer(dbh)

dbdimp.c

@@ -1240,6 +1240,18 @@ sqlite_compile_options()
     return (AV*)sv_2mortal((SV*)av);
 }
 
+SV *
+sqlite_db_filename(pTHX_ SV *dbh)
+{
+    D_imp_dbh(dbh);
+    const char *filename;
+
+    croak_if_db_is_null();
+
+    filename = sqlite3_db_filename(imp_dbh->db, "main");
+    return filename ? newSVpv(filename, 0) : &PL_sv_undef;
+}
+
 int
 sqlite_db_busy_timeout(pTHX_ SV *dbh, int timeout )
 {

dbdimp.h

@@ -107,6 +107,7 @@ AV* sqlite_compile_options();
 int sqlite_db_trace(pTHX_ SV *dbh, SV *func);
 int sqlite_db_profile(pTHX_ SV *dbh, SV *func);
 HV* sqlite_db_table_column_metadata(pTHX_ SV *dbh, SV *dbname, SV *tablename, SV *columnname);
+SV* sqlite_db_filename(pTHX_ SV *dbh);
 
 int sqlite_db_register_fts3_perl_tokenizer(pTHX_ SV *dbh);
 

lib/DBD/SQLite.pm

@@ -52,6 +52,7 @@ sub driver {
         DBD::SQLite::db->install_method('sqlite_trace');
         DBD::SQLite::db->install_method('sqlite_profile');
         DBD::SQLite::db->install_method('sqlite_table_column_metadata');
+        DBD::SQLite::db->install_method('sqlite_db_filename', { O => 0x0004 });
 
         $methods_are_installed++;
     }
@@ -211,6 +212,17 @@ sub do {
     return ($rows == 0) ? "0E0" : $rows;
 }
 
+sub ping {
+    my $dbh = shift;
+
+    # $file may be undef (ie. in-memory/temporary database)
+    my $file = DBD::SQLite::NEWAPI ? $dbh->sqlite_db_filename
+                                   : $dbh->func("db_filename");
+
+    return 0 if $file && !-f $file;
+    return $dbh->FETCH('Active') ? 1 : 0;
+}
+
 sub _get_version {
     return ( DBD::SQLite::db::FETCH($_[0], 'sqlite_version') );
 }
@@ -1318,6 +1330,12 @@ tells nothing about them.
 B<Note>: foreign key support in SQLite must be explicitly turned on through
 a C<PRAGMA> command; see L</"Foreign keys"> earlier in this manual.
 
+=head2 ping
+
+  my $bool = $dbh->ping;
+
+returns true if the database file exists (or the database is in-memory), and the database connection is active.
+
 =head1 DRIVER PRIVATE METHODS
 
 The following methods can be called via the func() method with a little
@@ -1348,6 +1366,10 @@ method instead. The usage of this is:
 Running C<$h-E<gt>last_insert_id("","","","")> is the equivalent of running
 C<$dbh-E<gt>sqlite_last_insert_rowid()> directly.
 
+=head2 $dbh->sqlite_db_filename()
+
+Retrieve the current (main) database filename. If the database is in-memory or temporary, this returns C<undef>.
+
 =head2 $dbh->sqlite_busy_timeout()
 
 Retrieve the current busy timeout.

t/52_db_filename.t

@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use t::lib::Test qw/connect_ok @CALL_FUNCS/;
+use Test::More;
+use Test::NoWarnings;
+
+plan tests => 6 * @CALL_FUNCS + 1;
+
+for my $func (@CALL_FUNCS) {
+	{
+		my $db = filename($func);
+		ok !$db, "in-memory database";
+	}
+
+	{
+		my $db = filename($func, dbfile => '');
+		ok !$db, "temporary database";
+	}
+
+	{
+		my $db = filename($func, dbfile => 'test.db');
+		like $db => qr/test\.db[\d]*$/i, "test.db";
+		unlink $db;
+	}
+}
+
+sub filename {
+	my $func = shift;
+	my $dbh = connect_ok(@_);
+	$dbh->$func('db_filename');
+}

t/lib/Test.pm

@@ -47,8 +47,8 @@ END   { clean() }
 # A simplified connect function for the most common case
 sub connect_ok {
 	my $attr = { @_ };
-	my $dbfile = delete $attr->{dbfile} || ':memory:';
+	my $dbfile = defined $attr->{dbfile} ? delete $attr->{dbfile} : ':memory:';
-	$dbfiles{$dbfile} = ($dbfile ne ':memory:') ? $dbfile . $$ : $dbfile;
+	$dbfiles{$dbfile} = (defined $dbfile && length $dbfile && $dbfile ne ':memory:') ? $dbfile . $$ : $dbfile;
 	my @params = ( "dbi:SQLite:dbname=$dbfiles{$dbfile}", '', '' );
 	if ( %$attr ) {
 		push @params, $attr;

t/rt_64177_ping_wipes_out_the_errstr.t

@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use t::lib::Test;
+use Test::More tests => 8;
+use Test::NoWarnings;
+
+my $dbh = connect_ok(RaiseError => 1, PrintError => 0);
+eval { $dbh->do('foobar') };
+ok $@, "raised error";
+ok $dbh->err, "has err";
+ok $dbh->errstr, "has errstr";
+ok $dbh->ping, "ping succeeded";
+ok $dbh->err, "err is not wiped out";
+ok $dbh->errstr, "errstr is not wiped out";