X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FSchema.pm;h=be36371673c1dca2bfe53567159b609922e72603;hb=8d6b1478d8fa6f7c76e313ee72a72d5eb4c24d03;hp=aff1d00b55a06fc682cf1f12c098a4cef4c1eff7;hpb=7caeae8f1f792d00b0511106d1b8ddd8b1b59ec1;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index aff1d00..be36371 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -1,23 +1,46 @@ package # hide from PAUSE DBICTest::Schema; -use base qw/DBIx::Class::Schema/; +use strict; +use warnings; +no warnings 'qw'; -no warnings qw/qw/; +use base 'DBIx::Class::Schema'; + +use Fcntl qw/:DEFAULT :seek :flock/; +use Time::HiRes 'sleep'; +use Path::Class::File; +use File::Spec; +use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/; +use namespace::clean; + +__PACKAGE__->mk_group_accessors(simple => 'custom_attr'); __PACKAGE__->load_classes(qw/ Artist + SequenceTest + BindType Employee CD - Link + Genre Bookmark - #Casecheck + Link #dummy Track Tag + Year2000CDs + Year1999CDs + CustomSql + Money + TimestampPrimaryKey /, { 'DBICTest::Schema' => [qw/ LinerNotes + Artwork + Artwork_to_Artist + Image + Lyrics + LyricVersion OneKey #dummy TwoKeys @@ -25,157 +48,174 @@ __PACKAGE__->load_classes(qw/ /]}, ( 'FourKeys', + 'FourKeys_to_TwoKeys', '#dummy', 'SelfRef', 'ArtistUndirectedMap', 'ArtistSourceName', + 'ArtistSubclass', 'Producer', 'CD_to_Producer', + 'Dummy', # this is a real result class we remove in the hook below ), - qw/SelfRefAlias TreeLike TwoKeyTreeLike Event/ + qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/, + qw/Collection CollectionObject TypedObject Owners BooksInLibrary/, + qw/ForceForeign Encoded/, ); -sub deploy { - my $self = shift; - - if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { - return $schema->next::method(@_); - } else { - open IN, "t/lib/sqlite.sql"; - my $sql; - { local $/ = undef; $sql = ; } - close IN; - $self->storage->dbh->do($_) for split(/;\n/, $sql); - } -} - -sub auto_populate { - my $self = shift; - - $self->storage->dbh->do("PRAGMA synchronous = OFF"); - - $self->populate('Artist', [ - [ qw/artistid name/ ], - [ 1, 'Caterwauler McCrae' ], - [ 2, 'Random Boy Band' ], - [ 3, 'We Are Goth' ], - ]); - - $self->populate('CD', [ - [ qw/cdid artist title year/ ], - [ 1, 1, "Spoonful of bees", 1999 ], - [ 2, 1, "Forkful of bees", 2001 ], - [ 3, 1, "Caterwaulin' Blues", 1997 ], - [ 4, 2, "Generic Manufactured Singles", 2001 ], - [ 5, 3, "Come Be Depressed With Us", 1998 ], - ]); - - $self->populate('LinerNotes', [ - [ qw/liner_id notes/ ], - [ 2, "Buy Whiskey!" ], - [ 4, "Buy Merch!" ], - [ 5, "Kill Yourself!" ], - ]); - - $self->populate('Tag', [ - [ qw/tagid cd tag/ ], - [ 1, 1, "Blue" ], - [ 2, 2, "Blue" ], - [ 3, 3, "Blue" ], - [ 4, 5, "Blue" ], - [ 5, 2, "Cheesy" ], - [ 6, 4, "Cheesy" ], - [ 7, 5, "Cheesy" ], - [ 8, 2, "Shiny" ], - [ 9, 4, "Shiny" ], - ]); - - $self->populate('TwoKeys', [ - [ qw/artist cd/ ], - [ 1, 1 ], - [ 1, 2 ], - [ 2, 2 ], - ]); +sub sqlt_deploy_hook { + my ($self, $sqlt_schema) = @_; - $self->populate('FourKeys', [ - [ qw/foo bar hello goodbye/ ], - [ 1, 2, 3, 4 ], - [ 5, 4, 3, 6 ], - ]); + $sqlt_schema->drop_table('dummy'); +} - $self->populate('OneKey', [ - [ qw/id artist cd/ ], - [ 1, 1, 1 ], - [ 2, 1, 2 ], - [ 3, 2, 2 ], - ]); - $self->populate('SelfRef', [ - [ qw/id name/ ], - [ 1, 'First' ], - [ 2, 'Second' ], - ]); - - $self->populate('SelfRefAlias', [ - [ qw/self_ref alias/ ], - [ 1, 2 ] - ]); +our $locker; +END { + # we need the $locker to be referenced here for delayed destruction + if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) { + #warn "$$ $0 $locktype LOCK RELEASED"; + } +} - $self->populate('ArtistUndirectedMap', [ - [ qw/id1 id2/ ], - [ 1, 2 ] - ]); +my $weak_registry = {}; + +sub connection { + my $self = shift->next::method(@_); + +# MASSIVE FIXME +# we can't really lock based on DSN, as we do not yet have a way to tell that e.g. +# DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst +# and +# DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0 +# are the same server +# hence we lock everything based on sqlt_type or just globally if not available +# just pretend we are python you know? :) + + + # when we get a proper DSN resolution sanitize to produce a portable lockfile name + # this may look weird and unnecessary, but consider running tests from + # windows over a samba share >.> + #utf8::encode($dsn); + #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge; + #$dsn =~ s/^dbi/dbi/i; + + # provide locking for physical (non-memory) DSNs, so that tests can + # safely run in parallel. While the harness (make -jN test) does set + # an envvar, we can not detect when a user invokes prove -jN. Hence + # perform the locking at all times, it shouldn't hurt. + # the lock fh *should* inherit across forks/subprocesses + # + # File locking is hard. Really hard. By far the best lock implementation + # I've seen is part of the guts of File::Temp. However it is sadly not + # reusable. Since I am not aware of folks doing NFS parallel testing, + # nor are we known to work on VMS, I am just going to punt this and + # use the portable-ish flock() provided by perl itself. If this does + # not work for you - patches more than welcome. + if ( + ! $DBICTest::global_exclusive_lock + and + ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ ) + and + ref($_[0]) ne 'CODE' + and + ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x + ) { + + my $locktype = do { + # guard against infinite recursion + local $ENV{DBICTEST_LOCK_HOLDER} = -1; + + # we need to connect a forced fresh clone so that we do not upset any state + # of the main $schema (some tests examine it quite closely) + local $@; + my $storage = eval { + my $st = ref($self)->connect(@{$self->storage->connect_info})->storage; + $st->ensure_connected; # do connect here, to catch a possible throw + $st; + }; + $storage + ? do { + my $t = $storage->sqlt_type || 'generic'; + eval { $storage->disconnect }; + $t; + } + : undef + ; + }; + + + # Never hold more than one lock. This solves the "lock in order" issues + # unrelated tests may have + # Also if there is no connection - there is no lock to be had + if ($locktype and (!$locker or $locker->{type} ne $locktype)) { + + warn "$$ $0 $locktype" if $locktype eq 'generic' or $locktype eq 'SQLite'; + + my $lockpath = File::Spec->tmpdir . "/.dbictest_$locktype.lock"; + + my $lock_fh; + { + my $u = local_umask(0); # so that the file opens as 666, and any user can lock + sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; + } + flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + #warn "$$ $0 $locktype LOCK GRABBED"; + + # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate + # if we do not do this we may end up trampling over some long-running END or somesuch + seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; + if (read ($lock_fh, my $old_pid, 100) ) { + for (1..50) { + kill (0, $old_pid) or last; + sleep 0.1; + } + } + #warn "$$ $0 $locktype POST GRAB WAIT"; + + truncate $lock_fh, 0; + seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; + $lock_fh->autoflush(1); + print $lock_fh $$; + + $ENV{DBICTEST_LOCK_HOLDER} ||= $$; + + $locker = { + type => $locktype, + fh => $lock_fh, + lock_name => "$lockpath", + }; + } + } - $self->populate('Producer', [ - [ qw/producerid name/ ], - [ 1, 'Matt S Trout' ], - [ 2, 'Bob The Builder' ], - [ 3, 'Fred The Phenotype' ], - ]); + if ($INC{'Test/Builder.pm'}) { + populate_weakregistry ( $weak_registry, $self->storage ); - $self->populate('CD_to_Producer', [ - [ qw/cd producer/ ], - [ 1, 1 ], - [ 1, 2 ], - [ 1, 3 ], - ]); + my $cur_connect_call = $self->storage->on_connect_call; - $self->populate('TreeLike', [ - [ qw/id parent name/ ], - [ 1, 0, 'foo' ], - [ 2, 1, 'bar' ], - [ 3, 2, 'baz' ], - [ 4, 3, 'quux' ], + $self->storage->on_connect_call([ + (ref $cur_connect_call eq 'ARRAY' + ? @$cur_connect_call + : ($cur_connect_call || ()) + ), + [sub { + populate_weakregistry( $weak_registry, shift->_dbh ) + }], ]); + } - $self->populate('Track', [ - [ qw/trackid cd position title/ ], - [ 4, 2, 1, "Stung with Success"], - [ 5, 2, 2, "Stripy"], - [ 6, 2, 3, "Sticky Honey"], - [ 7, 3, 1, "Yowlin"], - [ 8, 3, 2, "Howlin"], - [ 9, 3, 3, "Fowlin"], - [ 10, 4, 1, "Boring Name"], - [ 11, 4, 2, "Boring Song"], - [ 12, 4, 3, "No More Ideas"], - [ 13, 5, 1, "Sad"], - [ 14, 5, 2, "Under The Weather"], - [ 15, 5, 3, "Suicidal"], - [ 16, 1, 1, "The Bees Knees"], - [ 17, 1, 2, "Apiary"], - [ 18, 1, 3, "Beehind You"], - ]); + return $self; +} - $self->populate('Link', [ - [ qw/id title/ ], - [ 1, 'aaa' ] - ]); +sub clone { + my $self = shift->next::method(@_); + populate_weakregistry ( $weak_registry, $self ) + if $INC{'Test/Builder.pm'}; + $self; +} - $self->populate('Bookmark', [ - [ qw/id link/ ], - [ 1, 1 ] - ]); +END { + assert_empty_weakregistry($weak_registry, 'quiet'); } 1;