1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
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();
|
