From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

#!/usr/bin/perl -w
use strict;
use lib qw(t);
use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended);
my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } );
my ( undef, $extra_recommended ) = prove_reqs( { 'DBD::SQLite' => 0, } );
show_reqs( $required, { %$recommended, %$extra_recommended } );
my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} );
my $testdir = test_dir();
my @external_dbds = ( keys %$extra_recommended, grep { /^dbd::(?:dbm|csv)/i } keys %{$recommended} );
foreach my $test_dbd (@test_dbds)
{
my $dbh;
note("Running tests for $test_dbd");
my $temp = "";
# XXX
# my $test_dbd_tbl = "${test_dbd}::Table";
# $test_dbd_tbl->can("fetch") or $temp = "$temp";
$test_dbd eq "DBD::File" and $temp = "TEMP";
$test_dbd eq "SQL::Statement" and $temp = "TEMP";
my %extra_args;
if ( $test_dbd eq "DBD::DBM" and $recommended->{MLDBM} )
{
$extra_args{dbm_mldbm} = "Storable";
}
$dbh = connect(
$test_dbd,
{
PrintError => 0,
RaiseError => 0,
f_dir => $testdir,
%extra_args,
}
);
my $external_dsn;
if (%$extra_recommended)
{
if ( $extra_recommended->{'DBD::SQLite'} )
{
$external_dsn = "DBI:SQLite:dbname=" . File::Spec->catfile( $testdir, 'sqlite.db' );
}
}
elsif (@external_dbds)
{
if ( $test_dbd eq $external_dbds[0] and @external_dbds > 1 )
{
$external_dsn = $external_dbds[1];
}
else
{
$external_dsn = $external_dbds[0];
}
$external_dsn =~ s/^dbd::(\w+)$/dbi:$1:/i;
my @valid_dsns = DBI->data_sources( $external_dsn, { f_dir => $testdir } );
$external_dsn = $valid_dsns[0];
}
my ( $sth, $str );
####################
# IMPORT($AoA)
####################
$sth = $dbh->prepare("SELECT word FROM IMPORT(?) ORDER BY id DESC");
my $AoA = [
[qw( id word )], [qw( 4 Just )], [qw( 3 Another )], [qw( 2 Perl )],
[qw( 1 Hacker )],
];
$sth->execute($AoA);
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', 'Just^Another^Perl^Hacker^', 'IMPORT($AoA)' );
#######################
# IMPORT($AoH)
#######################
my $aoh = [
{
c1 => 1,
c2 => 9
},
{
c1 => 2,
c2 => 8
}
];
$sth = $dbh->prepare("SELECT C1,c2 FROM IMPORT(?)");
$sth->execute($aoh);
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 9^2 8^', 'IMPORT($AoH)' );
#######################
# IMPORT($internal_sth)
#######################
SKIP:
{
skip( "Need DBI statement handle - can't use when executing direct", 7 )
if ( $dbh->isa('TestLib::Direct') );
ok( $dbh->do( "CREATE $temp TABLE aoh AS IMPORT(?)", {}, $aoh ), 'CREATE AS IMPORT($aoh)' )
or diag( $dbh->errstr() );
$sth = $dbh->prepare("SELECT C1,c2 FROM aoh");
$sth->execute();
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 9^2 8^', 'SELECT FROM IMPORTED($AoH)' );
ok( $dbh->do( "CREATE $temp TABLE aoa AS IMPORT(?)", {}, $AoA ), 'CREATE AS IMPORT($aoa)' )
or diag( $dbh->errstr() );
$sth = $dbh->prepare("SELECT word FROM aoa ORDER BY id DESC");
$sth->execute();
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', 'Just^Another^Perl^Hacker^', 'SELECT FROM IMPORTED($AoA)' );
ok( $dbh->do("CREATE $temp TABLE tbl_copy AS SELECT * FROM aoa"), 'CREATE AS SELECT *' )
or diag( $dbh->errstr() );
$sth = $dbh->prepare("SELECT * FROM tbl_copy ORDER BY id ASC");
$sth->execute();
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 Hacker^2 Perl^3 Another^4 Just^', 'SELECT FROM "SELECTED(*)" tbl_copy' );
ok( $dbh->do("CREATE $temp TABLE tbl_extract AS SELECT * FROM aoa WHERE word LIKE 'H%'"), 'CREATE AS SELECT * with quoted restriction' )
or diag( $dbh->errstr() );
$sth = $dbh->prepare("SELECT * FROM tbl_extract ORDER BY id ASC");
$sth->execute();
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 Hacker^', 'SELECT FROM "SELECTED(*)" tbl_extract' );
$dbh->do($_) for split /\n/, <<"";
CREATE $temp TABLE tmp (id INTEGER, xphrase VARCHAR(30))
INSERT INTO tmp VALUES(1,'foo')
my $internal_sth = $dbh->prepare('SELECT * FROM tmp')->{sth}; # XXX breaks abstraction
$internal_sth->execute();
$sth = $dbh->prepare('SELECT * FROM IMPORT(?)');
$sth->execute($internal_sth);
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 foo^', 'IMPORT($internal_sth)' );
}
#######################
# IMPORT($external_sth)
#######################
SKIP:
{
skip( 'No external usable data source installed', 2 ) unless ($external_dsn);
my $xb_dbh = DBI->connect($external_dsn);
$xb_dbh->do($_) for split /\n/, <<"";
CREATE TABLE xb (id INTEGER, xphrase VARCHAR(30))
INSERT INTO xb VALUES(1,'foo')
my $xb_sth = $xb_dbh->prepare('SELECT * FROM xb');
$xb_sth->execute();
$sth = $dbh->prepare('SELECT * FROM IMPORT(?)');
$sth->execute($xb_sth);
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 foo^', 'SELECT IMPORT($external_sth)' );
SKIP:
{
skip( "Need DBI statement handle - can't use when executing direct", 2 )
if ( $dbh->isa('TestLib::Direct') );
$xb_sth = $xb_dbh->prepare('SELECT * FROM xb');
$xb_sth->execute();
ok( $dbh->do( "CREATE $temp TABLE xbi AS IMPORT(?)", {}, $xb_sth ),
'CREATE AS IMPORT($sth)' )
or diag( $dbh->errstr() );
$sth = $dbh->prepare('SELECT * FROM xbi');
$sth->execute();
$str = '';
while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; }
cmp_ok( $str, 'eq', '1 foo^', 'SELECT FROM IMPORTED ($external_sth)' );
}
$xb_dbh->do("DROP TABLE xb");
}
}
done_testing();