Run the entire test suite under replicated SQLite on DBICTEST_VIA_REPLICATED
[dbsrgits/DBIx-Class.git] / t / lib / DBICTest.pm
1 package # hide from PAUSE
2     DBICTest;
3
4 use strict;
5 use warnings;
6
7 use DBICTest::Util 'local_umask';
8 use DBICTest::Schema;
9 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
10 use DBIx::Class::_Util 'detected_reinvoked_destructor';
11 use Carp;
12 use Path::Class::File ();
13 use File::Spec;
14 use Fcntl qw/:DEFAULT :flock/;
15 use Config;
16
17 =head1 NAME
18
19 DBICTest - Library to be used by DBIx::Class test scripts
20
21 =head1 SYNOPSIS
22
23   use lib qw(t/lib);
24   use DBICTest;
25   use Test::More;
26
27   my $schema = DBICTest->init_schema();
28
29 =head1 DESCRIPTION
30
31 This module provides the basic utilities to write tests against
32 DBIx::Class.
33
34 =head1 EXPORTS
35
36 The module does not export anything by default, nor provides individual
37 function exports in the conventional sense. Instead the following tags are
38 recognized:
39
40 =head2 :DiffSQL
41
42 Same as C<use SQL::Abstract::Test
43 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
44 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
45 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
46
47 =head2 :GlobalLock
48
49 Some tests are very time sensitive and need to run on their own, without
50 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
51 using C<DBICTest> grabs a shared lock, and the few tests that request a
52 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
53
54 =head1 METHODS
55
56 =head2 init_schema
57
58   my $schema = DBICTest->init_schema(
59     no_deploy=>1,
60     no_populate=>1,
61     storage_type=>'::DBI::Replicated',
62     storage_type_args=>{
63       balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
64     },
65   );
66
67 This method removes the test SQLite database in t/var/DBIxClass.db
68 and then creates a new, empty database.
69
70 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
71 C<no_deploy> flag is set.
72
73 Also, by default, this method will call L<populate_schema()|/populate_schema>
74 by default, unless the C<no_deploy> or C<no_populate> flags are set.
75
76 =cut
77
78 # see L</:GlobalLock>
79 our ($global_lock_fh, $global_exclusive_lock);
80 sub import {
81     my $self = shift;
82
83     my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
84
85     {
86       my $u = local_umask(0); # so that the file opens as 666, and any user can lock
87       sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
88         or die "Unable to open $lockpath: $!";
89     }
90
91     for my $exp (@_) {
92         if ($exp eq ':GlobalLock') {
93             flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
94             $global_exclusive_lock = 1;
95         }
96         elsif ($exp eq ':DiffSQL') {
97             require SQL::Abstract::Test;
98             my $into = caller(0);
99             for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
100               no strict 'refs';
101               *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
102             }
103         }
104         else {
105             croak "Unknown export $exp requested from $self";
106         }
107     }
108
109     unless ($global_exclusive_lock) {
110         flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
111     }
112 }
113
114 END {
115     if ($global_lock_fh) {
116         # delay destruction even more
117     }
118 }
119
120 {
121     my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
122     $dir->mkpath unless -d "$dir";
123     $dir = "$dir";
124
125     sub _sqlite_dbfilename {
126         my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
127         $holder = $$ if $holder == -1;
128
129         # useful for missing cleanup debugging
130         #if ( $holder == $$) {
131         #  my $x = $0;
132         #  $x =~ s/\//#/g;
133         #  $holder .= "-$x";
134         #}
135
136         return "$dir/DBIxClass-$holder.db";
137     }
138
139     END {
140         _cleanup_dbfile();
141     }
142 }
143
144 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
145
146 my $need_global_cleanup;
147 sub _cleanup_dbfile {
148     # cleanup if this is us
149     if (
150       ! $ENV{DBICTEST_LOCK_HOLDER}
151         or
152       $ENV{DBICTEST_LOCK_HOLDER} == -1
153         or
154       $ENV{DBICTEST_LOCK_HOLDER} == $$
155     ) {
156         if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
157           $dbh->disconnect;
158         }
159
160         my $db_file = _sqlite_dbfilename();
161         unlink $_ for ($db_file, "${db_file}-journal");
162     }
163 }
164
165 sub has_custom_dsn {
166     return $ENV{"DBICTEST_DSN"} ? 1:0;
167 }
168
169 sub _sqlite_dbname {
170     my $self = shift;
171     my %args = @_;
172     return $self->_sqlite_dbfilename if (
173       defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
174     );
175     return ":memory:";
176 }
177
178 sub _database {
179     my $self = shift;
180     my %args = @_;
181
182     if ($ENV{DBICTEST_DSN}) {
183       return (
184         (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
185         { AutoCommit => 1, %args },
186       );
187     }
188     my $db_file = $self->_sqlite_dbname(%args);
189
190     for ($db_file, "${db_file}-journal") {
191       next unless -e $_;
192       unlink ($_) or carp (
193         "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
194       );
195     }
196
197     return ("dbi:SQLite:${db_file}", '', '', {
198       AutoCommit => 1,
199
200       # this is executed on every connect, and thus installs a disconnect/DESTROY
201       # guard for every new $dbh
202       on_connect_do => sub {
203
204         my $storage = shift;
205         my $dbh = $storage->_get_dbh;
206
207         # no fsync on commit
208         $dbh->do ('PRAGMA synchronous = OFF');
209
210         if (
211           $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
212             and
213           # the pragma does not work correctly before libsqlite 3.7.9
214           $storage->_server_info->{normalized_dbms_version} >= 3.007009
215         ) {
216           $dbh->do ('PRAGMA reverse_unordered_selects = ON');
217         }
218
219         # set a *DBI* disconnect callback, to make sure the physical SQLite
220         # file is still there (i.e. the test does not attempt to delete
221         # an open database, which fails on Win32)
222         if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
223           $dbh->{Callbacks} = {
224             connect => sub { $guard_cb->('connect') },
225             disconnect => sub { $guard_cb->('disconnect') },
226             DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
227           };
228         }
229       },
230       %args,
231     });
232 }
233
234 sub __mk_disconnect_guard {
235
236   my $db_file = shift;
237
238   return if (
239     # this perl leaks handles, delaying DESTROY, can't work right
240     DBIx::Class::_ENV_::PEEPEENESS
241       or
242     ! -f $db_file
243   );
244
245
246   my $orig_inode = (stat($db_file))[1]
247     or return;
248
249   my $clan_connect_caller = '*UNKNOWN*';
250   my $i;
251   while ( my ($pack, $file, $line) = caller(++$i) ) {
252     next if $file eq __FILE__;
253     next if $pack =~ /^DBIx::Class|^Try::Tiny/;
254     $clan_connect_caller = "$file line $line";
255   }
256
257   my $failed_once = 0;
258   my $connected = 1;
259
260   return sub {
261     return if $failed_once;
262
263     my $event = shift;
264     if ($event eq 'connect') {
265       # this is necessary in case we are disconnected and connected again, all within the same $dbh object
266       $connected = 1;
267       return;
268     }
269     elsif ($event eq 'disconnect') {
270       $connected = 0;
271     }
272     elsif ($event eq 'DESTROY' and ! $connected ) {
273       return;
274     }
275
276     my $fail_reason;
277     if (! -e $db_file) {
278       $fail_reason = 'is missing';
279     }
280     else {
281       my $cur_inode = (stat($db_file))[1];
282
283       if ($orig_inode != $cur_inode) {
284         my @inodes = ($orig_inode, $cur_inode);
285         # unless this is a fixed perl (P5RT#84590) pack/unpack before display
286         # to match the unsigned longs returned by `stat`
287         @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
288           unless $Config{st_ino_size};
289
290         $fail_reason = sprintf
291           'was recreated (initially inode %s, now %s)',
292           @inodes
293         ;
294       }
295     }
296
297     if ($fail_reason) {
298       $failed_once++;
299
300       require Test::Builder;
301       my $t = Test::Builder->new;
302       local $Test::Builder::Level = $Test::Builder::Level + 3;
303       $t->ok (0,
304         "$db_file originally created at $clan_connect_caller $fail_reason before $event "
305       . 'of DBI handle - a strong indicator that the database file was tampered with while '
306       . 'still being open. This action would fail massively if running under Win32, hence '
307       . 'we make sure it fails on any OS :)'
308       );
309     }
310
311     return; # this empty return is a DBI requirement
312   };
313 }
314
315 my $weak_registry = {};
316
317 sub init_schema {
318     my $self = shift;
319     my %args = @_;
320
321     my $schema;
322
323     if (
324       $ENV{DBICTEST_VIA_REPLICATED} &&=
325         ( !$args{storage_type} && !defined $args{sqlite_use_file} )
326     ) {
327       $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
328       $args{sqlite_use_file} = 1;
329     }
330
331     my @dsn = $self->_database(%args);
332
333     if ($args{compose_connection}) {
334       $need_global_cleanup = 1;
335       $schema = DBICTest::Schema->compose_connection(
336                   'DBICTest', @dsn
337                 );
338     } else {
339       $schema = DBICTest::Schema->compose_namespace('DBICTest');
340     }
341
342     if( $args{storage_type}) {
343       $schema->storage_type($args{storage_type});
344     }
345
346     if ( !$args{no_connect} ) {
347       $schema->connection(@dsn);
348
349       $schema->storage->connect_replicants(\@dsn)
350         if $ENV{DBICTEST_VIA_REPLICATED};
351     }
352
353     if ( !$args{no_deploy} ) {
354         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
355         __PACKAGE__->populate_schema( $schema )
356          if( !$args{no_populate} );
357     }
358
359     populate_weakregistry ( $weak_registry, $schema->storage )
360       if $INC{'Test/Builder.pm'} and $schema->storage;
361
362     return $schema;
363 }
364
365 END {
366   # Make sure we run after any cleanup in other END blocks
367   push @{ B::end_av()->object_2svref }, sub {
368     assert_empty_weakregistry($weak_registry, 'quiet');
369   };
370 }
371
372 =head2 deploy_schema
373
374   DBICTest->deploy_schema( $schema );
375
376 This method does one of two things to the schema.  It can either call
377 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
378 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
379 file and execute the SQL within. Either way you end up with a fresh set
380 of tables for testing.
381
382 =cut
383
384 sub deploy_schema {
385     my $self = shift;
386     my $schema = shift;
387     my $args = shift || {};
388
389     local $schema->storage->{debug}
390       if ($ENV{TRAVIS}||'') eq 'true';
391
392     if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
393         $schema->deploy($args);
394     } else {
395         my $filename = Path::Class::File->new(__FILE__)->dir
396           ->file('sqlite.sql')->stringify;
397         my $sql = do { local (@ARGV, $/) = $filename ; <> };
398         for my $chunk ( split (/;\s*\n+/, $sql) ) {
399           if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) {  # there is some real sql in the chunk - a non-space at the start of the string which is not a comment
400             $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
401           }
402         }
403     }
404     return;
405 }
406
407 =head2 populate_schema
408
409   DBICTest->populate_schema( $schema );
410
411 After you deploy your schema you can use this method to populate
412 the tables with test data.
413
414 =cut
415
416 sub populate_schema {
417     my $self = shift;
418     my $schema = shift;
419
420     local $schema->storage->{debug}
421       if ($ENV{TRAVIS}||'') eq 'true';
422
423     $schema->populate('Genre', [
424       [qw/genreid name/],
425       [qw/1       emo  /],
426     ]);
427
428     $schema->populate('Artist', [
429         [ qw/artistid name/ ],
430         [ 1, 'Caterwauler McCrae' ],
431         [ 2, 'Random Boy Band' ],
432         [ 3, 'We Are Goth' ],
433     ]);
434
435     $schema->populate('CD', [
436         [ qw/cdid artist title year genreid/ ],
437         [ 1, 1, "Spoonful of bees", 1999, 1 ],
438         [ 2, 1, "Forkful of bees", 2001 ],
439         [ 3, 1, "Caterwaulin' Blues", 1997 ],
440         [ 4, 2, "Generic Manufactured Singles", 2001 ],
441         [ 5, 3, "Come Be Depressed With Us", 1998 ],
442     ]);
443
444     $schema->populate('LinerNotes', [
445         [ qw/liner_id notes/ ],
446         [ 2, "Buy Whiskey!" ],
447         [ 4, "Buy Merch!" ],
448         [ 5, "Kill Yourself!" ],
449     ]);
450
451     $schema->populate('Tag', [
452         [ qw/tagid cd tag/ ],
453         [ 1, 1, "Blue" ],
454         [ 2, 2, "Blue" ],
455         [ 3, 3, "Blue" ],
456         [ 4, 5, "Blue" ],
457         [ 5, 2, "Cheesy" ],
458         [ 6, 4, "Cheesy" ],
459         [ 7, 5, "Cheesy" ],
460         [ 8, 2, "Shiny" ],
461         [ 9, 4, "Shiny" ],
462     ]);
463
464     $schema->populate('TwoKeys', [
465         [ qw/artist cd/ ],
466         [ 1, 1 ],
467         [ 1, 2 ],
468         [ 2, 2 ],
469     ]);
470
471     $schema->populate('FourKeys', [
472         [ qw/foo bar hello goodbye sensors/ ],
473         [ 1, 2, 3, 4, 'online' ],
474         [ 5, 4, 3, 6, 'offline' ],
475     ]);
476
477     $schema->populate('OneKey', [
478         [ qw/id artist cd/ ],
479         [ 1, 1, 1 ],
480         [ 2, 1, 2 ],
481         [ 3, 2, 2 ],
482     ]);
483
484     $schema->populate('SelfRef', [
485         [ qw/id name/ ],
486         [ 1, 'First' ],
487         [ 2, 'Second' ],
488     ]);
489
490     $schema->populate('SelfRefAlias', [
491         [ qw/self_ref alias/ ],
492         [ 1, 2 ]
493     ]);
494
495     $schema->populate('ArtistUndirectedMap', [
496         [ qw/id1 id2/ ],
497         [ 1, 2 ]
498     ]);
499
500     $schema->populate('Producer', [
501         [ qw/producerid name/ ],
502         [ 1, 'Matt S Trout' ],
503         [ 2, 'Bob The Builder' ],
504         [ 3, 'Fred The Phenotype' ],
505     ]);
506
507     $schema->populate('CD_to_Producer', [
508         [ qw/cd producer/ ],
509         [ 1, 1 ],
510         [ 1, 2 ],
511         [ 1, 3 ],
512     ]);
513
514     $schema->populate('TreeLike', [
515         [ qw/id parent name/ ],
516         [ 1, undef, 'root' ],
517         [ 2, 1, 'foo'  ],
518         [ 3, 2, 'bar'  ],
519         [ 6, 2, 'blop' ],
520         [ 4, 3, 'baz'  ],
521         [ 5, 4, 'quux' ],
522         [ 7, 3, 'fong'  ],
523     ]);
524
525     $schema->populate('Track', [
526         [ qw/trackid cd  position title/ ],
527         [ 4, 2, 1, "Stung with Success"],
528         [ 5, 2, 2, "Stripy"],
529         [ 6, 2, 3, "Sticky Honey"],
530         [ 7, 3, 1, "Yowlin"],
531         [ 8, 3, 2, "Howlin"],
532         [ 9, 3, 3, "Fowlin"],
533         [ 10, 4, 1, "Boring Name"],
534         [ 11, 4, 2, "Boring Song"],
535         [ 12, 4, 3, "No More Ideas"],
536         [ 13, 5, 1, "Sad"],
537         [ 14, 5, 2, "Under The Weather"],
538         [ 15, 5, 3, "Suicidal"],
539         [ 16, 1, 1, "The Bees Knees"],
540         [ 17, 1, 2, "Apiary"],
541         [ 18, 1, 3, "Beehind You"],
542     ]);
543
544     $schema->populate('Event', [
545         [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
546         [ 1, '2006-04-25 22:24:33', '2006-06-22 21:00:05', '2006-07-23', '2006-05-22 19:05:07', '2006-04-21 18:04:06'],
547     ]);
548
549     $schema->populate('Link', [
550         [ qw/id url title/ ],
551         [ 1, '', 'aaa' ]
552     ]);
553
554     $schema->populate('Bookmark', [
555         [ qw/id link/ ],
556         [ 1, 1 ]
557     ]);
558
559     $schema->populate('Collection', [
560         [ qw/collectionid name/ ],
561         [ 1, "Tools" ],
562         [ 2, "Body Parts" ],
563     ]);
564
565     $schema->populate('TypedObject', [
566         [ qw/objectid type value/ ],
567         [ 1, "pointy", "Awl" ],
568         [ 2, "round", "Bearing" ],
569         [ 3, "pointy", "Knife" ],
570         [ 4, "pointy", "Tooth" ],
571         [ 5, "round", "Head" ],
572     ]);
573     $schema->populate('CollectionObject', [
574         [ qw/collection object/ ],
575         [ 1, 1 ],
576         [ 1, 2 ],
577         [ 1, 3 ],
578         [ 2, 4 ],
579         [ 2, 5 ],
580     ]);
581
582     $schema->populate('Owners', [
583         [ qw/id name/ ],
584         [ 1, "Newton" ],
585         [ 2, "Waltham" ],
586     ]);
587
588     $schema->populate('BooksInLibrary', [
589         [ qw/id owner title source price/ ],
590         [ 1, 1, "Programming Perl", "Library", 23 ],
591         [ 2, 1, "Dynamical Systems", "Library",  37 ],
592         [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],
593     ]);
594 }
595
596 1;