use strict; use warnings; use Test::More; use FindBin qw($Bin); use vars qw($test_dsn $test_user $test_password $test_db); use DBD::MariaDB; $| = 1; # flush stdout asap to keep in sync with stderr $::COL_NULLABLE = 1; $::COL_KEY = 2; my $file = "$Bin/MariaDB.mtest"; BAIL_OUT "Cannot execute $file: $@" if -e $file and not eval { require $file }; $::test_dsn = $::test_dsn || $ENV{'DBI_DSN'} || 'DBI:MariaDB:database=test'; $::test_user = $::test_user || $ENV{'DBI_USER'} || ''; $::test_password = $::test_password || $ENV{'DBI_PASS'} || ''; BAIL_OUT "DBI test_dsn is not valid" unless $::test_dsn =~ /^[Dd][Bb][Ii]:MariaDB:/; if (not $::test_db) { my $driver_dsn = $::test_dsn; $driver_dsn =~ s/^[^:]*:[^:]*://; $::test_db = DBD::MariaDB->parse_dsn($driver_dsn)->{database}; $::test_db = 'test' unless $::test_db; } sub DbiTestConnect { my $err; my $dbh = eval { DBI->connect(@_) }; if ( $dbh ) { my ($current_charset, $current_collation) = $dbh->selectrow_array('SELECT @@character_set_database, @@collation_database'); my $expected_charset = $dbh->selectrow_array("SHOW CHARSET LIKE 'utf8mb4'") ? 'utf8mb4' : 'utf8'; my $expected_collation = "${expected_charset}_unicode_ci"; if ($current_charset ne $expected_charset) { $err = "Database charset is not $expected_charset, but $current_charset"; } elsif ($current_collation ne $expected_collation) { $err = "Database collation is not $expected_collation, but $current_collation"; } } else { if ( $@ ) { $err = $@; $err =~ s/ at \S+ line \d+\.?\s*$//; } if ( not $err ) { $err = $DBI::errstr; $err = "unknown error" unless $err; my $user = $_[1]; my $dsn = $_[0]; $dsn =~ s/^DBI:[^:]+://; $err = "DBI connect('$dsn','$user',...) failed: $err"; } my ($func, $file, $line) = caller; $err .= " at $file line $line."; } if ( defined $err ) { if ( $ENV{CONNECTION_TESTING} ) { BAIL_OUT "no database connection: $err"; } else { plan skip_all => "no database connection: $err"; } } return $dbh; } sub connection_id { my $dbh = shift; return 0 unless $dbh; # Paul DuBois says the following is more reliable than # $dbh->{'mariadb_thread_id'}; my @row = $dbh->selectrow_array("SELECT CONNECTION_ID()"); return $row[0]; } # nice function I saw in DBD::Pg test code sub byte_string { my $ret = join( "|" ,unpack( "C*" ,$_[0] ) ); return $ret; } =item CheckRoutinePerms() Check if the current user of the DBH has permissions to create/drop procedures if (!CheckRoutinePerms($dbh)) { plan skip_all => $dbh->errstr(); } =cut sub CheckRoutinePerms { my $dbh = shift @_; # check for necessary privs local $dbh->{PrintError} = 0; if (not eval { $dbh->do('DROP PROCEDURE IF EXISTS testproc') }) { return 0 if $dbh->errstr() =~ /alter routine command denied to user/; return 0 if $dbh->errstr() =~ /Table 'mysql\.proc' doesn't exist/; } return 1; }; 1;