t/common.pm

   1 package # Hide from PAUSE
   2     t::common;
   3
   4 use strict;
   5 use warnings FATAL => 'all';
   6
   7 use base 'Exporter';
   8 our @EXPORT_OK = qw(
   9     new_dbm
  10     new_fh
  11 );
  12
  13 use File::Spec ();
  14 use File::Temp qw( tempfile tempdir );
  15 use Fcntl qw( :flock );
  16
  17 my $parent = $ENV{WORK_DIR} || File::Spec->tmpdir;
  18 our $dir = tempdir( CLEANUP => 1, DIR => $parent );
  19
  20 sub new_fh {
  21     my ($fh, $filename) = tempfile( 'tmpXXXX', DIR => $dir, UNLINK => 1 );
  22
  23     # This is because tempfile() returns a flock'ed $fh on MacOSX.
  24     flock $fh, LOCK_UN;
  25
  26     return ($fh, $filename);
  27 }
  28
  29 sub new_dbm {
  30     my @args = @_;
  31     my ($fh, $filename) = new_fh();
  32
  33     my (@names, @reset_funcs, @extra_args);
  34
  35     unless ( $ENV{NO_TEST_FILE} ) {
  36         push @names, 'File';
  37         push @reset_funcs, undef;
  38         push @extra_args, [
  39             file => $filename,
  40         ];
  41     }
  42
  43     if ( $ENV{TEST_SQLITE} ) {
  44         (undef, my $filename) = new_fh();
  45         push @names, 'SQLite';
  46         push @reset_funcs, sub {
  47             require 'DBI.pm';
  48             my $dbh = DBI->connect(
  49                 "dbi:SQLite:dbname=$filename", '', '',
  50             );
  51             my $sql = do {
  52                 my $filename = 'etc/sqlite_tables.sql';
  53                 open my $fh, '<', $filename
  54                     or die "Cannot open '$filename' for reading: $!\n";
  55                 local $/;
  56                 <$fh>
  57             };
  58             foreach my $line ( split ';', $sql ) {
  59                 $dbh->do( "$line" ) if $line =~ /\S/;
  60             }
  61         };
  62         push @extra_args, [
  63             dbi => {
  64                 dsn      => "dbi:SQLite:dbname=$filename",
  65                 user     => '',
  66                 password => '',
  67             },
  68         ];
  69     }
  70
  71     if ( $ENV{TEST_MYSQL_DSN} ) {
  72         push @names, 'MySQL';
  73         push @reset_funcs, sub {
  74             require 'DBI.pm';
  75             my $dbh = DBI->connect(
  76                 $ENV{TEST_MYSQL_DSN},
  77                 $ENV{TEST_MYSQL_USER},
  78                 $ENV{TEST_MYSQL_PASS},
  79             );
  80             my $sql = do {
  81                 my $filename = 'etc/mysql_tables.sql';
  82                 open my $fh, '<', $filename
  83                     or die "Cannot open '$filename' for reading: $!\n";
  84                 local $/;
  85                 <$fh>
  86             };
  87             foreach my $line ( split ';', $sql ) {
  88                 $dbh->do( "$line" ) if $line =~ /\S/;
  89             }
  90         };
  91         push @extra_args, [
  92             dbi => {
  93                 dsn      => $ENV{TEST_MYSQL_DSN},
  94                 user     => $ENV{TEST_MYSQL_USER},
  95                 password => $ENV{TEST_MYSQL_PASS},
  96             },
  97         ];
  98     }
  99
 100     return sub {
 101         return unless @extra_args;
 102         my @these_args = @{ shift @extra_args };
 103         if ( my $reset = shift @reset_funcs ) {
 104             $reset->();
 105         }
 106         Test::More::diag( "Testing '@{[shift @names]}'\n" ) if $ENV{TEST_VERBOSE};
 107         return sub {
 108             DBM::Deep->new( @these_args, @args, @_ )
 109         };
 110     };
 111 }
 112
 113 1;
 114 __END__