t/lib/DBICTest/Schema.pm

   1 package # hide from PAUSE
   2     DBICTest::Schema;
   3
   4 use strict;
   5 use warnings;
   6 no warnings 'qw';
   7
   8 use base 'DBIx::Class::Schema';
   9
  10 use Fcntl qw/:DEFAULT :seek :flock/;
  11 use Time::HiRes 'sleep';
  12 use Path::Class::File;
  13 use File::Spec;
  14 use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/;
  15 use namespace::clean;
  16
  17 __PACKAGE__->mk_group_accessors(simple => 'custom_attr');
  18
  19 __PACKAGE__->load_classes(qw/
  20   Artist
  21   SequenceTest
  22   BindType
  23   Employee
  24   CD
  25   Genre
  26   Bookmark
  27   Link
  28   #dummy
  29   Track
  30   Tag
  31   Year2000CDs
  32   Year1999CDs
  33   CustomSql
  34   Money
  35   TimestampPrimaryKey
  36   /,
  37   { 'DBICTest::Schema' => [qw/
  38     LinerNotes
  39     Artwork
  40     Artwork_to_Artist
  41     Image
  42     Lyrics
  43     LyricVersion
  44     OneKey
  45     #dummy
  46     TwoKeys
  47     Serialized
  48   /]},
  49   (
  50     'FourKeys',
  51     'FourKeys_to_TwoKeys',
  52     '#dummy',
  53     'SelfRef',
  54     'ArtistUndirectedMap',
  55     'ArtistSourceName',
  56     'ArtistSubclass',
  57     'Producer',
  58     'CD_to_Producer',
  59     'Dummy',    # this is a real result class we remove in the hook below
  60   ),
  61   qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
  62   qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
  63   qw/ForceForeign Encoded/,
  64 );
  65
  66 sub sqlt_deploy_hook {
  67   my ($self, $sqlt_schema) = @_;
  68
  69   $sqlt_schema->drop_table('dummy');
  70 }
  71
  72
  73 our $locker;
  74 END {
  75   # we need the $locker to be referenced here for delayed destruction
  76   if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
  77     #warn "$$ $0 $locktype LOCK RELEASED";
  78   }
  79 }
  80
  81 my $weak_registry = {};
  82
  83 sub connection {
  84   my $self = shift->next::method(@_);
  85
  86 # MASSIVE FIXME
  87 # we can't really lock based on DSN, as we do not yet have a way to tell that e.g.
  88 # DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst
  89 #  and
  90 # DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0
  91 # are the same server
  92 # hence we lock everything based on sqlt_type or just globally if not available
  93 # just pretend we are python you know? :)
  94
  95
  96   # when we get a proper DSN resolution sanitize to produce a portable lockfile name
  97   # this may look weird and unnecessary, but consider running tests from
  98   # windows over a samba share >.>
  99   #utf8::encode($dsn);
 100   #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge;
 101   #$dsn =~ s/^dbi/dbi/i;
 102
 103   # provide locking for physical (non-memory) DSNs, so that tests can
 104   # safely run in parallel. While the harness (make -jN test) does set
 105   # an envvar, we can not detect when a user invokes prove -jN. Hence
 106   # perform the locking at all times, it shouldn't hurt.
 107   # the lock fh *should* inherit across forks/subprocesses
 108   #
 109   # File locking is hard. Really hard. By far the best lock implementation
 110   # I've seen is part of the guts of File::Temp. However it is sadly not
 111   # reusable. Since I am not aware of folks doing NFS parallel testing,
 112   # nor are we known to work on VMS, I am just going to punt this and
 113   # use the portable-ish flock() provided by perl itself. If this does
 114   # not work for you - patches more than welcome.
 115   if (
 116     ! $DBICTest::global_exclusive_lock
 117       and
 118     ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ )
 119       and
 120     ref($_[0]) ne 'CODE'
 121       and
 122     ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
 123   ) {
 124
 125     my $locktype = do {
 126       # guard against infinite recursion
 127       local $ENV{DBICTEST_LOCK_HOLDER} = -1;
 128
 129       # we need to connect a forced fresh clone so that we do not upset any state
 130       # of the main $schema (some tests examine it quite closely)
 131       local $@;
 132       my $storage = eval {
 133         my $st = ref($self)->connect(@{$self->storage->connect_info})->storage;
 134         $st->ensure_connected;  # do connect here, to catch a possible throw
 135         $st;
 136       };
 137       $storage
 138         ? do {
 139           my $t = $storage->sqlt_type || 'generic';
 140           eval { $storage->disconnect };
 141           $t;
 142         }
 143         : undef
 144       ;
 145     };
 146
 147
 148     # Never hold more than one lock. This solves the "lock in order" issues
 149     # unrelated tests may have
 150     # Also if there is no connection - there is no lock to be had
 151     if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
 152
 153       warn "$$ $0 $locktype" if $locktype eq 'generic' or $locktype eq 'SQLite';
 154
 155       my $lockpath = File::Spec->tmpdir . "/.dbictest_$locktype.lock";
 156
 157       my $lock_fh;
 158       {
 159         my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 160         sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
 161       }
 162       flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 163       #warn "$$ $0 $locktype LOCK GRABBED";
 164
 165       # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
 166       # if we do not do this we may end up trampling over some long-running END or somesuch
 167       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 168       if (read ($lock_fh, my $old_pid, 100) ) {
 169         for (1..50) {
 170           kill (0, $old_pid) or last;
 171           sleep 0.1;
 172         }
 173       }
 174       #warn "$$ $0 $locktype POST GRAB WAIT";
 175
 176       truncate $lock_fh, 0;
 177       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 178       $lock_fh->autoflush(1);
 179       print $lock_fh $$;
 180
 181       $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
 182
 183       $locker = {
 184         type => $locktype,
 185         fh => $lock_fh,
 186         lock_name => "$lockpath",
 187       };
 188     }
 189   }
 190
 191   if ($INC{'Test/Builder.pm'}) {
 192     populate_weakregistry ( $weak_registry, $self->storage );
 193
 194     my $cur_connect_call = $self->storage->on_connect_call;
 195
 196     $self->storage->on_connect_call([
 197       (ref $cur_connect_call eq 'ARRAY'
 198         ? @$cur_connect_call
 199         : ($cur_connect_call || ())
 200       ),
 201       [sub {
 202         populate_weakregistry( $weak_registry, shift->_dbh )
 203       }],
 204     ]);
 205   }
 206
 207   return $self;
 208 }
 209
 210 sub clone {
 211   my $self = shift->next::method(@_);
 212   populate_weakregistry ( $weak_registry, $self )
 213     if $INC{'Test/Builder.pm'};
 214   $self;
 215 }
 216
 217 END {
 218   assert_empty_weakregistry($weak_registry, 'quiet');
 219 }
 220
 221 1;