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