view release on metacpan or  search on metacpan

t/71mysql.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 DBIx::Class::Optional::Dependencies ();

use lib qw(t/lib);
use DBICTest;

plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mysql')
  unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql');

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

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

my $schema = DBICTest::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 DATE, 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:mysql:host=localhost;database=dbic_test', 'dbic_test', '');

# make sure sqlt_type overrides work (::Storage::DBI::mysql does this)
{
  my $schema = DBICTest::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) {

t/71mysql.t  view on Meta::CPAN

  is ($rs->count, 6, 'CDs created successfully');

  $rs = $rs->search ({}, {
    select => [ \ 'YEAR(year)' ], as => ['y'], distinct => 1,
  });

  my $y_rs = $rs->get_column ('y');

  warnings_exist { is_deeply (
    [ sort ($y_rs->all) ],
    [ 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 = DBICTest::Schema->connect($dsn, $user, $pass);
  $schema->resultset("Artist")->find(4);
  isa_ok($schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL');
}

# make sure the mysql_auto_reconnect buggery is avoided
{
  local $ENV{MOD_PERL} = 'boogiewoogie';
  my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
  ok (! $schema->storage->_get_dbh->{mysql_auto_reconnect}, 'mysql_auto_reconnect unset regardless of ENV' );

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

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

  ok ($orig_dbh, 'Got weak $dbh ref');
  ok ($orig_dbh->{mysql_auto_reconnect}, 'mysql_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 DBIx::Class::_ENV_::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 dbic-esque
    $rs->create({ name => "Hardcore Forker $$" });

    {
      local $TODO = "Perl $] is known to leak like a sieve"
        if DBIx::Class::_ENV_::PEEPEENESS;

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

    done_testing;
    exit 0;
  }

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