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