Commit | Line | Data |
bab77431 |
1 | package # hide from PAUSE |
c6d74d3e |
2 | DBICTest::Schema; |
a02675cd |
3 | |
65d35121 |
4 | use strict; |
5 | use warnings; |
6 | no warnings 'qw'; |
a02675cd |
7 | |
27a701f9 |
8 | use base 'DBICTest::BaseSchema'; |
65d35121 |
9 | |
8d6b1478 |
10 | use Fcntl qw/:DEFAULT :seek :flock/; |
11 | use Time::HiRes 'sleep'; |
9b871b00 |
12 | use DBICTest::RunMode; |
218b7c12 |
13 | use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; |
14 | use DBICTest::Util 'local_umask'; |
65d35121 |
15 | use namespace::clean; |
5ce32fc1 |
16 | |
71829446 |
17 | __PACKAGE__->mk_group_accessors(simple => 'custom_attr'); |
18 | |
a02675cd |
19 | __PACKAGE__->load_classes(qw/ |
5ce32fc1 |
20 | Artist |
b829910c |
21 | SequenceTest |
6ec7d1bb |
22 | BindType |
4e298a80 |
23 | Employee |
5ce32fc1 |
24 | CD |
370f2ba2 |
25 | Genre |
9c2c91ea |
26 | Bookmark |
97c96475 |
27 | Link |
5ce32fc1 |
28 | #dummy |
29 | Track |
30 | Tag |
a648ec78 |
31 | Year2000CDs |
1ee9aa72 |
32 | Year1999CDs |
b8b55c8e |
33 | CustomSql |
818ec409 |
34 | Money |
4d4dc518 |
35 | TimestampPrimaryKey |
5ce32fc1 |
36 | /, |
37 | { 'DBICTest::Schema' => [qw/ |
38 | LinerNotes |
4f6386b0 |
39 | Artwork |
d5633096 |
40 | Artwork_to_Artist |
4f6386b0 |
41 | Image |
42 | Lyrics |
43 | LyricVersion |
5ce32fc1 |
44 | OneKey |
45 | #dummy |
46 | TwoKeys |
9fcda149 |
47 | Serialized |
5ce32fc1 |
48 | /]}, |
49 | ( |
50 | 'FourKeys', |
3bd6e3e0 |
51 | 'FourKeys_to_TwoKeys', |
5ce32fc1 |
52 | '#dummy', |
53 | 'SelfRef', |
5efe4c79 |
54 | 'ArtistUndirectedMap', |
bab77431 |
55 | 'ArtistSourceName', |
b1fb2c94 |
56 | 'ArtistSubclass', |
7411204b |
57 | 'Producer', |
58 | 'CD_to_Producer', |
181c0934 |
59 | 'Dummy', # this is a real result class we remove in the hook below |
5ce32fc1 |
60 | ), |
dda9af55 |
61 | qw/SelfRefAlias TreeLike TwoKeyTreeLike Event EventTZ NoPrimaryKey/, |
a7e65bb5 |
62 | qw/Collection CollectionObject TypedObject Owners BooksInLibrary/, |
6e6b37a7 |
63 | qw/ForceForeign Encoded/, |
5ce32fc1 |
64 | ); |
a02675cd |
65 | |
d6c79cb3 |
66 | sub sqlt_deploy_hook { |
67 | my ($self, $sqlt_schema) = @_; |
68 | |
458e0292 |
69 | $sqlt_schema->drop_table('dummy'); |
d6c79cb3 |
70 | } |
71 | |
65d35121 |
72 | |
8d6b1478 |
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) == $$) { |
dc9818f6 |
77 | #warn "$$ $0 $locker->{type} LOCK RELEASED"; |
8d6b1478 |
78 | } |
65d35121 |
79 | } |
80 | |
8d6b1478 |
81 | my $weak_registry = {}; |
82 | |
6892eb09 |
83 | sub connection { |
84 | my $self = shift->next::method(@_); |
6918c70e |
85 | |
8d6b1478 |
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 | |
6642a36f |
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 | } |
8d6b1478 |
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 | |
dc9818f6 |
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 | |
9b871b00 |
168 | my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock"); |
8d6b1478 |
169 | |
a2c29633 |
170 | #warn "$$ $0 $locktype GRABBING LOCK"; |
8d6b1478 |
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 $!"; |
f3ec358e |
182 | my $old_pid; |
183 | if ( |
184 | read ($lock_fh, $old_pid, 100) |
185 | and |
186 | ($old_pid) = $old_pid =~ /^(\d+)$/ |
187 | ) { |
8d6b1478 |
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 | |
6918c70e |
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 | |
8d6b1478 |
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'}; |
6892eb09 |
233 | $self; |
234 | } |
235 | |
65d35121 |
236 | END { |
237 | assert_empty_weakregistry($weak_registry, 'quiet'); |
238 | } |
239 | |
a02675cd |
240 | 1; |