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