Author: REHSACK
Date: Fri Jun 4 08:06:04 2010
New Revision: 14108
Added:
dbi/trunk/t/52dbm_complex.t
Log:
Add complex join tests - first shot testing joins work and import between tables ...
Added: dbi/trunk/t/52dbm_complex.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/52dbm_complex.t Fri Jun 4 08:06:04 2010
@@ -0,0 +1,326 @@
+#!perl -w
+$| = 1;
+
+use strict;
+use File::Path;
+use File::Spec;
+use Test::More;
+use Cwd;
+use Config qw(%Config);
+use Storable qw(dclone);
+
+my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i;
+my $haveSS;
+
+use DBI;
+use vars qw( @mldbm_types @dbm_types );
+
+BEGIN
+{
+
+ # 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+ # next line forces use of Nano rather than default behaviour
+ # $ENV{DBI_SQL_NANO}=1;
+ # This is done in zv*n*_50dbm_simple.t
+
+ if ( eval { require 'MLDBM.pm'; } )
+ {
+ push @mldbm_types, qw(Data::Dumper Storable); # both in CORE
+ push @mldbm_types, 'FreezeThaw' if eval { require 'FreezeThaw.pm' };
+ push @mldbm_types, 'YAML' if eval { require MLDBM::Serializer::YAML; };
+ }
+
+ # Potential DBM modules in preference order (SDBM_File first)
+ # skip NDBM and ODBM as they don't support EXISTS
+ my @dbms = qw(SDBM_File GDBM_File DB_File BerkeleyDB NDBM_File ODBM_File);
+ my @use_dbms = @ARGV;
+ if ( !@use_dbms && $ENV{DBD_DBM_TEST_BACKENDS} )
+ {
+ @use_dbms = split ' ', $ENV{DBD_DBM_TEST_BACKENDS};
+ }
+
+ if ( lc "@use_dbms" eq "all" )
+ {
+ # test with as many of the major DBM types as are available
+ @dbm_types = grep {
+ eval { local $^W; require "$_.pm" }
+ } @dbms;
+ }
+ elsif (@use_dbms)
+ {
+ @dbm_types = @use_dbms;
+ }
+ else
+ {
+ # we only test SDBM_File by default to avoid tripping up
+ # on any broken DBM's that may be installed in odd places.
+ # It's only DBD::DBM we're trying to test here.
+ # (However, if SDBM_File is not available, then use another.)
+ for my $dbm (@dbms)
+ {
+ if ( eval { local $^W; require "$dbm.pm" } )
+ {
+ @dbm_types = ($dbm);
+ last;
+ }
+ }
+ }
+
+ eval { require SQL::Statement; require DBD::DBM; $haveSS = DBD::DBM::Statement->isa('SQL::Statement'); };
+
+ if ( eval { require List::MoreUtils; } )
+ {
+ List::MoreUtils->import("part");
+ }
+ else
+ {
+ # XXX from PP part of List::MoreUtils
+ eval <<'EOP';
+sub part(&@) {
+ my ($code, @list) = @_;
+ my @parts;
+ push @{ $parts[$code->($_)] }, $_ for @list;
+ return @parts;
+}
+EOP
+ }
+}
+
+my $dir = File::Spec->catdir( getcwd(), 'test_output' );
+
+rmtree $dir;
+END { rmtree $dir }
+mkpath $dir;
+
+plan skip_all => "These tests require SQL::Statement" unless ( $haveSS and @mldbm_types );
+plan skip_all => "Needs more love to run with Gofer, too" if( $using_dbd_gofer );
+
+my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, } );
+
+my $suffix;
+
+sub load_tables
+{
+ my ( $dbmtype, $serializer ) = @_;
+ my $last_suffix = $suffix;
+ $serializer =~ s/::/_/g;
+ $suffix = join( "_", $$, $dbmtype, $serializer );
+ if ($last_suffix)
+ {
+ for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s))
+ {
+ my $readsql = sprintf "SELECT * FROM $table", $last_suffix;
+ my $impsql = sprintf "CREATE TABLE $table AS IMPORT (?)", $suffix;
+ my ($readsth);
+ ok( $readsth = $dbh->prepare($readsql), "prepare: $readsql" );
+ ok( $readsth->execute(), "execute: $readsql" );
+ ok( $dbh->do( $impsql, {}, $readsth ), $impsql );
+ }
+ }
+ else
+ {
+ for my $sql ( split( "\n", join( '', <<'EOD' ) ) )
+CREATE TABLE APPL_%s (id INT, applname CHAR, appluniq CHAR, version CHAR, appl_type CHAR)
+CREATE TABLE PREC_%s (id INT, appl_id INT, node_id INT, precedence INT)
+CREATE TABLE NODE_%s (id INT, nodename CHAR, os CHAR, version CHAR)
+CREATE TABLE LANDSCAPE_%s (id INT, landscapename CHAR)
+CREATE TABLE CONTACT_%s (id INT, surname CHAR, familyname CHAR, phone CHAR, userid CHAR, mailaddr CHAR)
+CREATE TABLE NM_LANDSCAPE_%s (id INT, ls_id INT, obj_id INT, obj_type INT)
+CREATE TABLE APPL_CONTACT_%s (id INT, contact_id INT, appl_id INT, contact_type CHAR)
+
+INSERT INTO APPL_%s VALUES ( 1, 'ZQF', 'ZFQLIN', '10.2.0.4', 'Oracle DB')
+INSERT INTO APPL_%s VALUES ( 2, 'YRA', 'YRA-UX', '10.2.0.2', 'Oracle DB')
+INSERT INTO APPL_%s VALUES ( 3, 'PRN1', 'PRN1-4.B2', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 4, 'PRN2', 'PRN2-4.B2', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 5, 'PRN1', 'PRN1-4.B1', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 7, 'PRN2', 'PRN2-4.B1', '1.1.22', 'CUPS' )
+INSERT INTO APPL_%s VALUES ( 8, 'sql-stmt', 'SQL::Statement', '1.21', 'Project Web-Site')
+INSERT INTO APPL_%s VALUES ( 9, 'cpan.org', 'http://www.cpan.org/', '1.0', 'Web-Site')
+INSERT INTO APPL_%s VALUES (10, 'httpd', 'cpan-apache', '2.2.13', 'Web-Server')
+INSERT INTO APPL_%s VALUES (11, 'cpan-mods', 'cpan-mods', '8.4.1', 'PostgreSQL DB')
+INSERT INTO APPL_%s VALUES (12, 'cpan-authors', 'cpan-authors', '8.4.1', 'PostgreSQL DB')
+
+INSERT INTO NODE_%s VALUES ( 1, 'ernie', 'RHEL', '5.2')
+INSERT INTO NODE_%s VALUES ( 2, 'bert', 'RHEL', '5.2')
+INSERT INTO NODE_%s VALUES ( 3, 'statler', 'FreeBSD', '7.2')
+INSERT INTO NODE_%s VALUES ( 4, 'waldorf', 'FreeBSD', '7.2')
+INSERT INTO NODE_%s VALUES ( 5, 'piggy', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 6, 'kermit', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 7, 'samson', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 8, 'tiffy', 'NetBSD', '5.0.2')
+INSERT INTO NODE_%s VALUES ( 9, 'rowlf', 'Debian Lenny', '5.0')
+INSERT INTO NODE_%s VALUES (10, 'fozzy', 'Debian Lenny', '5.0')
+
+INSERT INTO PREC_%s VALUES ( 1, 1, 1, 1)
+INSERT INTO PREC_%s VALUES ( 2, 1, 2, 2)
+INSERT INTO PREC_%s VALUES ( 3, 2, 2, 1)
+INSERT INTO PREC_%s VALUES ( 4, 2, 1, 2)
+INSERT INTO PREC_%s VALUES ( 5, 3, 5, 1)
+INSERT INTO PREC_%s VALUES ( 6, 3, 7, 2)
+INSERT INTO PREC_%s VALUES ( 7, 4, 6, 1)
+INSERT INTO PREC_%s VALUES ( 8, 4, 8, 2)
+INSERT INTO PREC_%s VALUES ( 9, 5, 7, 1)
+INSERT INTO PREC_%s VALUES (10, 5, 5, 2)
+INSERT INTO PREC_%s VALUES (11, 6, 8, 1)
+INSERT INTO PREC_%s VALUES (12, 7, 6, 2)
+INSERT INTO PREC_%s VALUES (13, 10, 9, 1)
+INSERT INTO PREC_%s VALUES (14, 10, 10, 1)
+INSERT INTO PREC_%s VALUES (15, 8, 9, 1)
+INSERT INTO PREC_%s VALUES (16, 8, 10, 1)
+INSERT INTO PREC_%s VALUES (17, 9, 9, 1)
+INSERT INTO PREC_%s VALUES (17, 9, 10, 1)
+INSERT INTO PREC_%s VALUES (18, 11, 3, 1)
+INSERT INTO PREC_%s VALUES (19, 11, 4, 2)
+INSERT INTO PREC_%s VALUES (20, 12, 4, 1)
+INSERT INTO PREC_%s VALUES (21, 12, 3, 2)
+
+INSERT INTO LANDSCAPE_%s VALUES (1, 'Logistic')
+INSERT INTO LANDSCAPE_%s VALUES (2, 'Infrastructure')
+INSERT INTO LANDSCAPE_%s VALUES (3, 'CPAN')
+
+INSERT INTO CONTACT_%s VALUES ( 1, 'Hans Peter', 'Mueller', '12345', 'HPMUE', '[email protected]')
+INSERT INTO CONTACT_%s VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', '[email protected]')
+INSERT INTO CONTACT_%s VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', '[email protected]')
+INSERT INTO CONTACT_%s VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', '[email protected]')
+
+-- TYPE: 1: APPL 2: NODE 3: CONTACT
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 1, 1, 1, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 2, 1, 2, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 3, 3, 3, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 4, 3, 4, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 5, 2, 5, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 6, 2, 6, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 7, 2, 7, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 8, 2, 8, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES ( 9, 3, 9, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES (10, 3,10, 2)
+INSERT INTO NM_LANDSCAPE_%s VALUES (11, 1, 1, 1)
+INSERT INTO NM_LANDSCAPE_%s VALUES (12, 2, 2, 1)
+INSERT INTO NM_LANDSCAPE_%s VALUES (13, 2, 2, 3)
+INSERT INTO NM_LANDSCAPE_%s VALUES (14, 3, 1, 3)
+
+INSERT INTO APPL_CONTACT_%s VALUES (1, 3, 1, 'OWNER')
+INSERT INTO APPL_CONTACT_%s VALUES (2, 3, 2, 'OWNER')
+INSERT INTO APPL_CONTACT_%s VALUES (3, 4, 3, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (4, 4, 4, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (5, 4, 5, 'ADMIN')
+INSERT INTO APPL_CONTACT_%s VALUES (6, 4, 6, 'ADMIN')
+EOD
+ {
+ chomp $sql;
+ $sql =~ s/^\s+//;
+ $sql =~ s/--.*$//;
+ $sql =~ s/\s+$//;
+ next if ( '' eq $sql );
+ $sql = sprintf $sql, $suffix;
+ ok( $dbh->do($sql), $sql );
+ }
+ }
+}
+
+sub do_tests
+{
+ my ( $dbmtype, $serializer ) = @_;
+
+ note "Running do_tests for $dbmtype + $serializer";
+
+ $dbh->{dbm_type} = $dbmtype;
+ $dbh->{dbm_mldbm} = $serializer;
+
+ load_tables( $dbmtype, $serializer );
+
+ my %joins;
+ my $sql;
+
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, nodename },
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s }, ($suffix) x 3 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ),
+ );
+
+ $joins{$sql} = [
+ 'ZQF~ZFQLIN~10.2.0.4~ernie', 'ZQF~ZFQLIN~10.2.0.4~bert',
+ 'YRA~YRA-UX~10.2.0.2~bert', 'YRA~YRA-UX~10.2.0.2~ernie',
+ 'cpan-mods~cpan-mods~8.4.1~statler', 'cpan-mods~cpan-mods~8.4.1~waldorf',
+ 'cpan-authors~cpan-authors~8.4.1~waldorf', 'cpan-authors~cpan-authors~8.4.1~statler',
+ ];
+
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, landscapename, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, LANDSCAPE_%s, NM_LANDSCAPE_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND NM_LANDSCAPE_%s.obj_id=APPL_%s.id AND}, ($suffix) x 4 ),
+ sprintf( q{NM_LANDSCAPE_%s.obj_type=1 AND NM_LANDSCAPE_%s.ls_id=LANDSCAPE_%s.id}, ($suffix) x 3 ),
+ );
+ $joins{$sql} = [
+ 'ZQF~ZFQLIN~10.2.0.4~Logistic~ernie', 'ZQF~ZFQLIN~10.2.0.4~Logistic~bert',
+ 'YRA~YRA-UX~10.2.0.2~Infrastructure~bert', 'YRA~YRA-UX~10.2.0.2~Infrastructure~ernie',
+ ];
+ $sql = join( " ",
+ q{SELECT applname, appluniq, version, surname, familyname, phone, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id AND}, ($suffix) x 4 ),
+ sprintf( q{APPL_CONTACT_%s.contact_id=CONTACT_%s.id AND PREC_%s.PRECEDENCE=1}, ($suffix) x 3 ),
+ );
+ $joins{$sql} = [
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit',
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ ];
+ $sql = join( " ",
+ q{SELECT DISTINCT applname, appluniq, version, surname, familyname, phone, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s, CONTACT_%s, APPL_CONTACT_%s}, ($suffix) x 5 ),
+ sprintf( q{WHERE appl_type='CUPS' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id AND APPL_CONTACT_%s.appl_id=APPL_%s.id}, ($suffix) x 4 ),
+ sprintf( q{AND APPL_CONTACT_%s.contact_id=CONTACT_%s.id}, ($suffix) x 2 ),
+ );
+ $joins{$sql} = [
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~piggy',
+ 'PRN1~PRN1-4.B1~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ 'PRN1~PRN1-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~samson',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~kermit',
+ 'PRN2~PRN2-4.B2~1.1.22~Helge~Brunft~+41-123-45678-09~tiffy',
+ ];
+ $sql = join( " ",
+ q{SELECT CONCAT('[% NOW %]') AS "timestamp", applname, appluniq, version, nodename},
+ sprintf( q{FROM APPL_%s, PREC_%s, NODE_%s}, ($suffix) x 3 ),
+ sprintf( q{WHERE appl_type LIKE '%%DB' AND APPL_%s.id=PREC_%s.appl_id AND}, ($suffix) x 2 ),
+ sprintf( q{PREC_%s.node_id=NODE_%s.id}, ($suffix) x 2 ),
+ );
+ $joins{$sql} = [
+ '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~ernie',
+ '[% NOW %]~ZQF~ZFQLIN~10.2.0.4~bert',
+ '[% NOW %]~YRA~YRA-UX~10.2.0.2~bert',
+ '[% NOW %]~YRA~YRA-UX~10.2.0.2~ernie',
+ '[% NOW %]~cpan-mods~cpan-mods~8.4.1~statler',
+ '[% NOW %]~cpan-mods~cpan-mods~8.4.1~waldorf',
+ '[% NOW %]~cpan-authors~cpan-authors~8.4.1~waldorf',
+ '[% NOW %]~cpan-authors~cpan-authors~8.4.1~statler',
+ ];
+
+ while ( my ( $sql, $result ) = each(%joins) )
+ {
+ my $sth = $dbh->prepare($sql);
+ eval { $sth->execute() };
+ warn $@ if $@;
+ my @res;
+ while ( my $row = $sth->fetchrow_arrayref() )
+ {
+ push( @res, join( '~', @{$row} ) );
+ }
+ is( join( '^', sort @res ), join( '^', sort @{$result} ), $sql );
+ }
+}
+
+foreach my $dbmtype (@dbm_types)
+{
+ foreach my $serializer (@mldbm_types)
+ {
+ do_tests( $dbmtype, $serializer );
+ }
+}
+
+done_testing();
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.