view release on metacpan or  search on metacpan

t/lib/SQLiteTest.pm  view on Meta::CPAN

package SQLiteTest;

# Support code for DBD::SQLite tests

use strict;
use Exporter   ();
use File::Spec ();
use Test::More ();

our @ISA     = 'Exporter';
our @EXPORT  = qw/
    connect_ok dies dbfile @CALL_FUNCS $sqlite_call
    has_sqlite requires_sqlite requires_unicode_support
    allow_warnings has_compile_option has_fts
/;
our @CALL_FUNCS;
our $sqlite_call;

my $parent;
my %dbfiles;

BEGIN {
	# Allow tests to load modules bundled in /inc
	unshift @INC, 'inc';

	$parent = $$;
}

# Always load the DBI module
use DBI ();

sub dbfile { $dbfiles{$_[0]} ||= (defined $_[0] && length $_[0] && $_[0] ne ':memory:') ? $_[0] . $$ : $_[0] }

# Delete temporary files
sub clean {
	return
		if $$ != $parent;
	for my $dbfile (values %dbfiles) {
		next if $dbfile eq ':memory:';
		unlink $dbfile if -f $dbfile;
		my $journal = $dbfile . '-journal';
		unlink $journal if -f $journal;
	}
}

# Clean up temporary test files both at the beginning and end of the
# test script.
BEGIN { clean() }
END   { clean() }

# A simplified connect function for the most common case
sub connect_ok {
	my $attr = { @_ };
	my $dbfile = dbfile(defined $attr->{dbfile} ? delete $attr->{dbfile} : ':memory:');
	my @params = ( "dbi:SQLite:dbname=$dbfile", '', '' );
	if ( %$attr ) {
		push @params, $attr;
	}
	my $dbh = DBI->connect( @params );
	Test::More::isa_ok( $dbh, 'DBI::db' );
	return $dbh;
}

=head2 dies

  dies(sub {...}, $regex_expected_error, $msg)

Tests that the given coderef (most probably a closure) dies with the
expected error message.

=cut

sub dies {

t/lib/SQLiteTest.pm  view on Meta::CPAN

=cut

sub has_compile_option {
  my $option = shift;
  require DBD::SQLite;
  return unless DBD::SQLite->can('compile_options');
  my $re = ref $option eq ref qr// ? $option : qr/\b$option\b/;
  grep /$re/, DBD::SQLite::compile_options();
}

=head2 has_fts

  has_fts();
  has_fts(3);

returns true if DBD::SQLite is built with FTS.

=cut

sub has_fts {
  if (my $version = shift) {
    has_compile_option("ENABLE_FTS$version");
  } else {
    has_compile_option(qr/\bENABLE_FTS\d\b/);
  }
}

=head2 has_sqlite

  has_sqlite('3.6.11');

returns true if DBD::SQLite is built with a version of SQLite equal to or higher than the specified version.

=cut

sub has_sqlite {
  my $version = shift;
  my @version_parts = split /\./, $version;
  my $format = '%d%03d%03d';
  my $version_number = sprintf $format, @version_parts[0..2];
  use DBD::SQLite;
  return ($DBD::SQLite::sqlite_version_number && $DBD::SQLite::sqlite_version_number >= $version_number) ? 1 : 0;
}

=head2 requires_sqlite

  BEGIN { requires_sqlite('3.6.11'); }

skips all the tests if DBD::SQLite is not built with a version of SQLite equal to or higher than the specified version.

=cut

sub requires_sqlite {
  my $version = shift;
  unless (has_sqlite($version)) {
    Test::More::plan skip_all => "this test requires SQLite $version and newer";
    exit;
  }
}

=head2 requires_unicode_support

  BEGIN { requires_unicode_support(); }

skips all the tests if Perl does not have sane Unicode support.

=cut

sub requires_unicode_support {
  unless ($] >= 5.008005) {
    Test::More::plan skip_all => "Unicode is not supported before 5.8.5";
    exit;
  }
}

=head2 allow_warnings

  allow_warnings { eval {...} };

hides SQLite warnings from Test::FailWarnings.

=cut

sub allow_warnings (&) {
  my $code = shift;
  local $SIG{__WARN__} = sub { Test::More::note @_ };
  $code->();
}

1;