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 qw/populate_weakregistry assert_empty_weakregistry local_umask/;
  14 use namespace::clean;
  15
  16 __PACKAGE__->mk_group_accessors(simple => 'custom_attr');
  17
  18 __PACKAGE__->load_classes(qw/
  19   Artist
  20   SequenceTest
  21   BindType
  22   Employee
  23   CD
  24   Genre
  25   Bookmark
  26   Link
  27   #dummy
  28   Track
  29   Tag
  30   Year2000CDs
  31   Year1999CDs
  32   CustomSql
  33   Money
  34   TimestampPrimaryKey
  35   /,
  36   { 'DBICTest::Schema' => [qw/
  37     LinerNotes
  38     Artwork
  39     Artwork_to_Artist
  40     Image
  41     Lyrics
  42     LyricVersion
  43     OneKey
  44     #dummy
  45     TwoKeys
  46     Serialized
  47   /]},
  48   (
  49     'FourKeys',
  50     'FourKeys_to_TwoKeys',
  51     '#dummy',
  52     'SelfRef',
  53     'ArtistUndirectedMap',
  54     'ArtistSourceName',
  55     'ArtistSubclass',
  56     'Producer',
  57     'CD_to_Producer',
  58     'Dummy',    # this is a real result class we remove in the hook below
  59   ),
  60   qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/,
  61   qw/Collection CollectionObject TypedObject Owners BooksInLibrary/,
  62   qw/ForceForeign Encoded/,
  63 );
  64
  65 sub sqlt_deploy_hook {
  66   my ($self, $sqlt_schema) = @_;
  67
  68   $sqlt_schema->drop_table('dummy');
  69 }
  70
  71
  72 our $locker;
  73 END {
  74   # we need the $locker to be referenced here for delayed destruction
  75   if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) {
  76     #warn "$$ $0 $locktype LOCK RELEASED";
  77   }
  78 }
  79
  80 my $weak_registry = {};
  81
  82 sub connection {
  83   my $self = shift->next::method(@_);
  84
  85 # MASSIVE FIXME
  86 # we can't really lock based on DSN, as we do not yet have a way to tell that e.g.
  87 # DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst
  88 #  and
  89 # DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0
  90 # are the same server
  91 # hence we lock everything based on sqlt_type or just globally if not available
  92 # just pretend we are python you know? :)
  93
  94
  95   # when we get a proper DSN resolution sanitize to produce a portable lockfile name
  96   # this may look weird and unnecessary, but consider running tests from
  97   # windows over a samba share >.>
  98   #utf8::encode($dsn);
  99   #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge;
 100   #$dsn =~ s/^dbi/dbi/i;
 101
 102   # provide locking for physical (non-memory) DSNs, so that tests can
 103   # safely run in parallel. While the harness (make -jN test) does set
 104   # an envvar, we can not detect when a user invokes prove -jN. Hence
 105   # perform the locking at all times, it shouldn't hurt.
 106   # the lock fh *should* inherit across forks/subprocesses
 107   #
 108   # File locking is hard. Really hard. By far the best lock implementation
 109   # I've seen is part of the guts of File::Temp. However it is sadly not
 110   # reusable. Since I am not aware of folks doing NFS parallel testing,
 111   # nor are we known to work on VMS, I am just going to punt this and
 112   # use the portable-ish flock() provided by perl itself. If this does
 113   # not work for you - patches more than welcome.
 114   if (
 115     ! $DBICTest::global_exclusive_lock
 116       and
 117     ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ )
 118       and
 119     ref($_[0]) ne 'CODE'
 120       and
 121     ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
 122   ) {
 123
 124     my $locktype = do {
 125       # guard against infinite recursion
 126       local $ENV{DBICTEST_LOCK_HOLDER} = -1;
 127
 128       # we need to connect a forced fresh clone so that we do not upset any state
 129       # of the main $schema (some tests examine it quite closely)
 130       local $@;
 131       my $storage = eval {
 132         my $st = ref($self)->connect(@{$self->storage->connect_info})->storage;
 133         $st->ensure_connected;  # do connect here, to catch a possible throw
 134         $st;
 135       };
 136       $storage
 137         ? do {
 138           my $t = $storage->sqlt_type || 'generic';
 139           eval { $storage->disconnect };
 140           $t;
 141         }
 142         : undef
 143       ;
 144     };
 145
 146
 147     # Never hold more than one lock. This solves the "lock in order" issues
 148     # unrelated tests may have
 149     # Also if there is no connection - there is no lock to be had
 150     if ($locktype and (!$locker or $locker->{type} ne $locktype)) {
 151
 152       warn "$$ $0 $locktype" if (
 153         ($locktype eq 'generic' or $locktype eq 'SQLite')
 154           and
 155         DBICTest::RunMode->is_author
 156       );
 157
 158       my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock");
 159
 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;