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 | |
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 | |
dc9818f6 |
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 | |
9b871b00 |
157 | my $lockpath = DBICTest::RunMode->tmpdir->file(".dbictest_$locktype.lock"); |
8d6b1478 |
158 | |
a2c29633 |
159 | #warn "$$ $0 $locktype GRABBING LOCK"; |
8d6b1478 |
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 $!"; |
f3ec358e |
171 | my $old_pid; |
172 | if ( |
173 | read ($lock_fh, $old_pid, 100) |
174 | and |
175 | ($old_pid) = $old_pid =~ /^(\d+)$/ |
176 | ) { |
8d6b1478 |
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 | |
6918c70e |
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 | |
8d6b1478 |
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'}; |
6892eb09 |
222 | $self; |
223 | } |
224 | |
65d35121 |
225 | END { |
226 | assert_empty_weakregistry($weak_registry, 'quiet'); |
227 | } |
228 | |
a02675cd |
229 | 1; |