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 my $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 @reset_funcs;
  34     my @extra_args;
  35
  36     unless ( $ENV{NO_TEST_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         $filename = 'test.db';
  46         push @reset_funcs, sub {
  47             my $dbh = DBI->connect(
  48                 "dbi:SQLite:dbname=$filename", '', '',
  49             );
  50             my $sql = do {
  51                 my $filename = 'etc/sqlite_tables.sql';
  52                 open my $fh, '<', $filename
  53                     or die "Cannot open '$filename' for reading: $!\n";
  54                 local $/;
  55                 <$fh>
  56             };
  57             foreach my $line ( split ';', $sql ) {
  58                 $dbh->do( "$line" ) if $line =~ /\S/;
  59             }
  60         };
  61         push @extra_args, [
  62             dbi => {
  63                 dsn      => "dbi:SQLite:dbname=$filename",
  64                 user     => '',
  65                 password => '',
  66             },
  67         ];
  68     }
  69
  70     if ( $ENV{TEST_MYSQL_DSN} ) {
  71         push @reset_funcs, sub {
  72             my $dbh = DBI->connect(
  73                 $ENV{TEST_MYSQL_DSN},
  74                 $ENV{TEST_MYSQL_USER},
  75                 $ENV{TEST_MYSQL_PASS},
  76             );
  77             my $sql = do {
  78                 my $filename = 'etc/mysql_tables.sql';
  79                 open my $fh, '<', $filename
  80                     or die "Cannot open '$filename' for reading: $!\n";
  81                 local $/;
  82                 <$fh>
  83             };
  84             foreach my $line ( split ';', $sql ) {
  85                 $dbh->do( "$line" ) if $line =~ /\S/;
  86             }
  87         };
  88         push @extra_args, [
  89             dbi => {
  90                 dsn      => $ENV{TEST_MYSQL_DSN},
  91                 user     => $ENV{TEST_MYSQL_USER},
  92                 password => $ENV{TEST_MYSQL_PASS},
  93             },
  94         ];
  95     }
  96
  97     return sub {
  98         return unless @extra_args;
  99         my @these_args = @{ shift @extra_args };
 100         if ( my $reset = shift @reset_funcs ) {
 101             $reset->();
 102         }
 103         return sub {
 104             DBM::Deep->new(
 105                 @these_args, @args, @_,
 106             );
 107         };
 108     };
 109 }
 110
 111 1;
 112 __END__