view release on metacpan or  search on metacpan

t/01-operations.t  view on Meta::CPAN

# tests inpsired/copied from https://github.com/Perl5/DBIx-Class/blob/maint/0.0828xx/t/71mysql.t

use strict;
use warnings;

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

use Scalar::Util qw/weaken/;

use lib qw(t/lib);
use MyApp::Schema;

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

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

my $schema = MyApp::Schema->connect( $dsn, $user, $pass );

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

# initialize tables
$dbh->do("SET foreign_key_checks=0");
$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),
    picture MEDIUMBLOB
)"
);
$dbh->do("DROP TABLE IF EXISTS owner");
$dbh->do(
    "CREATE TABLE owner (
    id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,
    name VARCHAR(100) NOT NULL
)"
);
$dbh->do("DROP TABLE IF EXISTS book");
$dbh->do(
    "CREATE TABLE book (
    id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY,
    source VARCHAR(100) NOT NULL,
    owner INTEGER NOT NULL,
    title VARCHAR(100) NOT NULL,
    price INTEGER
)"
);
$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 TEXT
)"
);
$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");

t/01-operations.t  view on Meta::CPAN

    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 => 'Chocolate Rain' } );

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

    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 the 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';
};

subtest 'find hooks determine driver' => sub {
    my $schema = MyApp::Schema->connect( $dsn, $user, $pass );
    $schema->resultset('Artist')->find(4);
    isa_ok( $schema->storage->sql_maker, 'DBIx::Class::SQLMaker::MySQL' );
};

subtest 'mariadb_auto_reconnect' => sub {
    local $ENV{MOD_PERL} = 'whyisperllikethis';
    my $schema = MyApp::Schema->connect( $dsn, $user, $pass );
    ok(
        !$schema->storage->_get_dbh->{mariadb_auto_reconnect},
        'mariadb_auto_reconnect unset regardless of ENV'
    );

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

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

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

    # kill our $dbh
    $schema_autorecon->storage->_dbh(undef);
    ok( !defined $orig_dbh, '$dbh handle is gone' );

    $rs->create( { name => "test" } );
    ok( !defined $orig_dbh,
        'DBIC operation triggered reconnect - old $dbh is gone' );
    ok( $rs->find( { name => "test" } ), 'Expected row created' );
};

subtest 'blob round trip' => sub {
    my $new =
      $schema->resultset('Artist')->create( { name => 'blob round trip', picture => "\302\243", name => "\302\243" } );
    ok( $new->artistid, 'Auto-PK worked' );

    my $artist2_rs =
      $schema->resultset('Artist')->search( { artistid => $new->artistid } );

    is($artist2_rs->single->picture, "\302\243", "Round-tripped a blob");
    is($artist2_rs->single->name,    "\302\243", "Round-tripped non-ASCII characters");
};

# We don't want to assume that the database has defaulted to utf8mb4, so we
# only test with a >255 basic multilingual plane character.
subtest 'basic multilingual plane round trip' => sub {
    my $new =
      $schema->resultset('Artist')->create( { name => chr(0x2603) } );
    ok( $new->artistid, 'Auto-PK worked' );

    my $artist2_rs =
      $schema->resultset('Artist')->search( { artistid => $new->artistid } );

    is($artist2_rs->single->name, chr(0x2603), "Round-tripped a snowman");
};

done_testing;