diff options
Diffstat (limited to 't/52dbm_complex.t')
| -rw-r--r-- | t/52dbm_complex.t | 359 |
1 files changed, 359 insertions, 0 deletions
diff --git a/t/52dbm_complex.t b/t/52dbm_complex.t new file mode 100644 index 0000000..31dc6e3 --- /dev/null +++ b/t/52dbm_complex.t @@ -0,0 +1,359 @@ +#!perl -w +$| = 1; + +use strict; +use warnings; + +require DBD::DBM; + +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; + +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; }; + push @mldbm_types, 'JSON' if eval { require MLDBM::Serializer::JSON; }; + } + + # 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; + } + } + } + + 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 $haveSS = DBD::DBM::Statement->isa('SQL::Statement'); + +plan skip_all => "DBI::SQL::Nano is being used" unless ( $haveSS ); +plan skip_all => "Not running with MLDBM" unless ( @mldbm_types ); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, { f_dir => $dir, } ); + +my $suffix; +my $tbl_meta; + +sub break_at_warn +{ + note "break here"; +} +$SIG{__WARN__} = \&break_at_warn; +$SIG{__DIE__} = \&break_at_warn; + +sub load_tables +{ + my ( $dbmtype, $dbmmldbm ) = @_; + my $last_suffix; + + if ($using_dbd_gofer) + { + $dbh->disconnect(); + $dbh = DBI->connect( "dbi:DBM:", undef, undef, { f_dir => $dir, dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm } ); + } + else + { + $last_suffix = $suffix; + $dbh->{dbm_type} = $dbmtype; + $dbh->{dbm_mldbm} = $dbmmldbm; + } + + (my $serializer = $dbmmldbm ) =~ 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 ) or warn $dbh->errstr(); + } + } + 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 (18, 9, 10, 1) +INSERT INTO PREC_%s VALUES (19, 11, 3, 1) +INSERT INTO PREC_%s VALUES (20, 11, 4, 2) +INSERT INTO PREC_%s VALUES (21, 12, 4, 1) +INSERT INTO PREC_%s VALUES (22, 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', 'hp-mueller@here.com') +INSERT INTO CONTACT_%s VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', 'k-inge@here.com') +INSERT INTO CONTACT_%s VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', 'lola.ngyuen@customer.com') +INSERT INTO CONTACT_%s VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', 'helge.brunft@external-dc.at') + +-- 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 ); + } + } + + for my $table (qw(APPL_%s PREC_%s NODE_%s LANDSCAPE_%s CONTACT_%s NM_LANDSCAPE_%s APPL_CONTACT_%s)) + { + my $tbl_name = lc sprintf($table, $suffix); + $tbl_meta->{$tbl_name} = { dbm_type => $dbmtype, dbm_mldbm => $dbmmldbm }; + } + + unless ($using_dbd_gofer) + { + my $tbl_known_meta = $dbh->dbm_get_meta( "+", [ qw(dbm_type dbm_mldbm) ] ); + is_deeply( $tbl_known_meta, $tbl_meta, "Know meta" ); + } +} + +sub do_tests +{ + my ( $dbmtype, $serializer ) = @_; + + note "Running do_tests for $dbmtype + $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(); |