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
 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       # this will release whatever lock we may currently be holding
 154       # which is fine since the type does not match as checked above
 155       undef $locker;
 156
 157       my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock");
 158
 159       #warn "$$ $0 $locktype GRABBING LOCK";
 160       my $lock_fh;
 161       {
 162         my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 163         sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!";
 164       }
 165       flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 166       #warn "$$ $0 $locktype LOCK GRABBED";
 167
 168       # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
 169       # if we do not do this we may end up trampling over some long-running END or somesuch
 170       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 171       my $old_pid;
 172       if (
 173         read ($lock_fh, $old_pid, 100)
 174           and
 175         ($old_pid) = $old_pid =~ /^(\d+)$/
 176       ) {
 177         for (1..50) {
 178           kill (0, $old_pid) or last;
 179           sleep 0.1;
 180         }
 181       }
 182       #warn "$$ $0 $locktype POST GRAB WAIT";
 183
 184       truncate $lock_fh, 0;
 185       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
 186       $lock_fh->autoflush(1);
 187       print $lock_fh $$;
 188
 189       $ENV{DBICTEST_LOCK_HOLDER} ||= $$;
 190
 191       $locker = {
 192         type => $locktype,
 193         fh => $lock_fh,
 194         lock_name => "$lockpath",
 195       };
 196     }
 197   }
 198
 199   if ($INC{'Test/Builder.pm'}) {
 200     populate_weakregistry ( $weak_registry, $self->storage );
 201
 202     my $cur_connect_call = $self->storage->on_connect_call;
 203
 204     $self->storage->on_connect_call([
 205       (ref $cur_connect_call eq 'ARRAY'
 206         ? @$cur_connect_call
 207         : ($cur_connect_call || ())
 208       ),
 209       [sub {
 210         populate_weakregistry( $weak_registry, shift->_dbh )
 211       }],
 212     ]);
 213   }
 214
 215   return $self;
 216 }
 217
 218 sub clone {
 219   my $self = shift->next::method(@_);
 220   populate_weakregistry ( $weak_registry, $self )
 221     if $INC{'Test/Builder.pm'};
 222   $self;
 223 }
 224
 225 END {
 226   assert_empty_weakregistry($weak_registry, 'quiet');
 227 }
 228
 229 1;