view release on metacpan or  search on metacpan

t/10-mysql.t  view on Meta::CPAN

use strict;
use warnings;

use Test::More;
use Test::Exception;
use Test::Warn;

use DBI::Const::GetInfoType;
use Scalar::Util qw/weaken/;

use DBIO::Test;
use DBIO::Util qw(peepeeness);

my ($dsn, $user, $pass) = @ENV{map { "DBIO_TEST_MYSQL_${_}" } qw/DSN USER PASS/};

plan skip_all => 'Set $ENV{DBIO_TEST_MYSQL_DSN}, _USER and _PASS to run this test'
  unless ($dsn && $user);

my $schema = DBIO::Test::Schema->connect($dsn, $user, $pass, { quote_names => 1 });

my $dbh = $schema->storage->dbh;

$dbh->do("DROP TABLE IF EXISTS artist;");

$dbh->do("CREATE TABLE artist (artistid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100), `rank` INTEGER NOT NULL DEFAULT '13', charfield CHAR(10));");

$dbh->do("DROP TABLE IF EXISTS cd;");

$dbh->do("CREATE TABLE cd (cdid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, artist INTEGER, title TEXT, year VARCHAR(20), genreid INTEGER, single_track INTEGER);");

$dbh->do("DROP TABLE IF EXISTS producer;");

$dbh->do("CREATE TABLE producer (producerid INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name TEXT);");

$dbh->do("DROP TABLE IF EXISTS cd_to_producer;");

$dbh->do("CREATE TABLE cd_to_producer (cd INTEGER,producer INTEGER);");

$dbh->do("DROP TABLE IF EXISTS owners;");

$dbh->do("CREATE TABLE owners (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name VARCHAR(100) NOT NULL);");

$dbh->do("DROP TABLE IF EXISTS books;");

$dbh->do("CREATE TABLE books (id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, source VARCHAR(100) NOT NULL, owner integer NOT NULL, title varchar(100) NOT NULL,  price integer);");

#'dbi:MariaDB:host=localhost;database=dbio_test', 'dbio_test', '');

# make sure sqlt_type overrides work (::Storage::DBI::mysql does this)
{
  my $schema = DBIO::Test::Schema->connect($dsn, $user, $pass);

  ok (!$schema->storage->_dbh, 'definitely not connected');
  is ($schema->storage->sqlt_type, 'MySQL', 'sqlt_type correct pre-connection');
}

# This is in Core now, but it's here just to test that it doesn't break
$schema->class('Artist')->load_components('PK::Auto');

# test primary key handling
my $new = $schema->resultset('Artist')->create({ name => 'foo' });
ok($new->artistid, "Auto-PK worked");

# test LIMIT support
for (1..6) {
    $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
}
my $it = $schema->resultset('Artist')->search( {},
    { rows => 3,

t/10-mysql.t  view on Meta::CPAN

    [ sort keys %$cds_per_year ],
    'Years group successfully',
  ) } qr/
    \QUse of distinct => 1 while selecting anything other than a column \E
    \Qdeclared on the primary ResultSource is deprecated\E
  /x, 'deprecation warning';


  $rs->create ({ artist => 1, year => '0-1-1', title => 'Jesus Rap' });

  is_deeply (
    [ sort $y_rs->all ],
    [ 0, sort keys %$cds_per_year ],
    'Zero-year groups successfully',
  );

  # convoluted search taken verbatim from list
  my $restrict_rs = $rs->search({ -and => [
    year => { '!=', 0 },
    year => { '!=', undef }
  ]});

  warnings_exist { is_deeply (
    [ sort $restrict_rs->get_column('y')->all ],
    [ sort $y_rs->all ],
    'Zero year was correctly excluded from resultset',
  ) } qr/
    \QUse of distinct => 1 while selecting anything other than a column \E
    \Qdeclared on the primary ResultSource is deprecated\E
  /x, 'deprecation warning';
}

# make sure find hooks determine driver
{
  my $schema = DBIO::Test::Schema->connect($dsn, $user, $pass);
  $schema->resultset("Artist")->find(4);
  isa_ok($schema->storage->sql_maker, 'DBIO::MySQL::SQLMaker');
}

# make sure the auto_reconnect buggery is avoided
# DBD::MariaDB uses mariadb_auto_reconnect, DBD::mysql uses mysql_auto_reconnect
{
  local $ENV{MOD_PERL} = 'boogiewoogie';
  my $schema = DBIO::Test::Schema->connect($dsn, $user, $pass);
  my $is_mariadb = $schema->storage->_get_dbh->{Driver}{Name} eq 'MariaDB';
  my $ar_attr = $is_mariadb ? 'mariadb_auto_reconnect' : 'mysql_auto_reconnect';
  ok (! $schema->storage->_get_dbh->{$ar_attr}, 'auto_reconnect unset regardless of ENV' );

  # Make sure hardcore forking action still works even if auto_reconnect
  # is true (test inspired by ether)

  SKIP: {
    # DBD::MariaDB handles fork+reconnect differently from DBD::mysql — the
    # child process spins instead of cleanly reconnecting. Skip the fork
    # portion of this test when using DBD::MariaDB.
    skip 'DBD::MariaDB fork+auto_reconnect behaves differently', 6
      if $is_mariadb;

    my $schema_autorecon = DBIO::Test::Schema->connect($dsn, $user, $pass, { $ar_attr => 1 });
    my $orig_dbh = $schema_autorecon->storage->_get_dbh;
    weaken $orig_dbh;

    ok ($orig_dbh, 'Got weak $dbh ref');
    ok ($orig_dbh->{$ar_attr}, 'auto_reconnect is properly set if explicitly requested' );

    my $rs = $schema_autorecon->resultset('Artist');

    my ($parent_in, $child_out);
    pipe( $parent_in, $child_out ) or die "Pipe open failed: $!";
    my $pid = fork();
    if (! defined $pid ) {
      die "fork() failed: $!"
    }
    elsif ($pid) {
      close $child_out;

      # sanity check
      $schema_autorecon->storage->dbh_do(sub {
        is ($_[1], $orig_dbh, 'Storage holds correct $dbh in parent');
      });

      # kill our $dbh
      $schema_autorecon->storage->_dbh(undef);

      {
        local $TODO = "Perl $] is known to leak like a sieve"
          if peepeeness;

        ok (! defined $orig_dbh, 'Parent $dbh handle is gone');
      }
    }
    else {
      close $parent_in;

      #simulate a  subtest to not confuse the parent TAP emission
      my $tb = Test::More->builder;
      $tb->reset;
      for (qw/output failure_output todo_output/) {
        close $tb->$_;
        open ($tb->$_, '>&', $child_out);
      }

      # wait for parent to kill its $dbh
      sleep 1;

      # try to do something dbio-esque
      $rs->create({ name => "Hardcore Forker $$" });

      {
        local $TODO = "Perl $] is known to leak like a sieve"
          if peepeeness;

        ok (! defined $orig_dbh, 'DBIO operation triggered reconnect - old $dbh is gone');
      }

      done_testing;
      exit 0;
    }

    while (my $ln = <$parent_in>) {
      print "   $ln";