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 'DBICTest::BaseSchema';
   9
  10 use Fcntl qw/:DEFAULT :seek :flock/;
  11 use Time::HiRes 'sleep';
  12 use DBICTest::RunMode;
  13 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
  14 use DBICTest::Util '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 $locker->{type} 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     # DBD::Firebird and DBD::InterBase could very well talk to the same RDBMS
 148     # make an educated guesstimate based on the DSN
 149     # (worst case scenario we are wrong and the scripts have to wait on each
 150     # other even without actually being able to interfere among themselves)
 151     if (
 152       ($locktype||'') eq 'InterBase'
 153         and
 154       $_[0] =~ /firebird/i
 155     ) {
 156       $locktype = 'Firebird';
 157     }
 158
 159     # Never hold more than one lock. This solves the "lock in order" issues
 160     # unrelated tests may have
 161     # Also if there is no connection - there is no lock to be had
 162     if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
 163
 164       # this will release whatever lock we may currently be holding
 165       # which is fine since the type does not match as checked above
 166       undef $locker;
 167
 168       my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock");
 169
 170       #warn "$$ $0 $locktype GRABBING LOCK";
 171       my $lock_fh;
 172       {
 173         my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 174         sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
 175       }
 176       flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 177       #warn "$$ $0 $locktype LOCK GRABBED";
 178
 179       # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
 180       # if we do not do this we may end up trampling over some long-running END or somesuch
 181       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 182       my $old_pid;
 183       if (
 184         read ($lock_fh, $old_pid, 100)
 185           and
 186         ($old_pid) = $old_pid =~ /^(\d+)$/
 187       ) {
 188         for (1..50) {
 189           kill (0, $old_pid) or last;
 190           sleep 0.1;
 191         }
 192       }
 193       #warn "$$ $0 $locktype POST GRAB WAIT";
 194
 195       truncate $lock_fh, 0;
 196       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 197       $lock_fh->autoflush(1);
 198       print $lock_fh $$;
 199
 200       $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
 201
 202       $locker = {
 203         type => $locktype,
 204         fh => $lock_fh,
 205         lock_name => "$lockpath",
 206       };
 207     }
 208   }
 209
 210   if ($INC{'Test/Builder.pm'}) {
 211     populate_weakregistry ( $weak_registry, $self->storage );
 212
 213     my $cur_connect_call = $self->storage->on_connect_call;
 214
 215     $self->storage->on_connect_call([
 216       (ref $cur_connect_call eq 'ARRAY'
 217         ? @$cur_connect_call
 218         : ($cur_connect_call || ())
 219       ),
 220       [sub {
 221         populate_weakregistry( $weak_registry, shift->_dbh )
 222       }],
 223     ]);
 224   }
 225
 226   return $self;
 227 }
 228
 229 sub clone {
 230   my $self = shift->next::method(@_);
 231   populate_weakregistry ( $weak_registry, $self )
 232     if $INC{'Test/Builder.pm'};
 233   $self;
 234 }
 235
 236 END {
 237   assert_empty_weakregistry($weak_registry, 'quiet');
 238 }
 239
 240 1;