Commit | Line | Data |
65d35121 |
1 | package DBICTest::Util; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
bbcc1fe8 |
6 | # this noop trick initializes the STDOUT, so that the TAP::Harness |
7 | # issued IO::Select->can_read calls (which are blocking wtf wtf wtf) |
8 | # keep spinning and scheduling jobs |
9 | # This results in an overall much smoother job-queue drainage, since |
10 | # the Harness blocks less |
11 | # (ideally this needs to be addressed in T::H, but a quick patchjob |
12 | # broke everything so tabling it for now) |
13 | BEGIN { |
14 | if ($INC{'Test/Builder.pm'}) { |
15 | local $| = 1; |
16 | print "#\n"; |
17 | } |
18 | } |
19 | |
d931aae1 |
20 | use constant DEBUG_TEST_CONCURRENCY_LOCKS => |
21 | ( ($ENV{DBICTEST_DEBUG_CONCURRENCY_LOCKS}||'') =~ /^(\d+)$/ )[0] |
22 | || |
23 | 0 |
24 | ; |
25 | |
8d6b1478 |
26 | use Config; |
a3a17a15 |
27 | use Carp 'confess'; |
89c7c05d |
28 | use Fcntl ':flock'; |
a446d7f8 |
29 | use Scalar::Util qw(blessed refaddr); |
87f4bab0 |
30 | use DBIx::Class::_Util; |
65d35121 |
31 | |
32 | use base 'Exporter'; |
d931aae1 |
33 | our @EXPORT_OK = qw( |
34 | dbg stacktrace |
35 | local_umask |
36 | visit_namespaces |
37 | check_customcond_args |
89c7c05d |
38 | await_flock DEBUG_TEST_CONCURRENCY_LOCKS |
d931aae1 |
39 | ); |
40 | |
41 | if (DEBUG_TEST_CONCURRENCY_LOCKS) { |
42 | require DBI; |
43 | my $oc = DBI->can('connect'); |
44 | no warnings 'redefine'; |
45 | *DBI::connect = sub { |
46 | DBICTest::Util::dbg("Connecting to $_[1]"); |
47 | goto $oc; |
48 | } |
49 | } |
50 | |
51 | sub dbg ($) { |
52 | require Time::HiRes; |
53 | printf STDERR "\n%.06f %5s %-78s %s\n", |
54 | scalar Time::HiRes::time(), |
55 | $$, |
56 | $_[0], |
57 | $0, |
58 | ; |
59 | } |
8d6b1478 |
60 | |
89c7c05d |
61 | # File locking is hard. Really hard. By far the best lock implementation |
62 | # I've seen is part of the guts of File::Temp. However it is sadly not |
63 | # reusable. Since I am not aware of folks doing NFS parallel testing, |
64 | # nor are we known to work on VMS, I am just going to punt this and |
65 | # use the portable-ish flock() provided by perl itself. If this does |
66 | # not work for you - patches more than welcome. |
67 | # |
68 | # This figure esentially means "how long can a single test hold a |
69 | # resource before everyone else gives up waiting and aborts" or |
70 | # in other words "how long does the longest test-group legitimally run?" |
71 | my $lock_timeout_minutes = 15; # yes, that's long, I know |
72 | my $wait_step_seconds = 0.25; |
73 | |
74 | sub await_flock ($$) { |
75 | my ($fh, $locktype) = @_; |
76 | |
77 | my ($res, $tries); |
78 | while( |
79 | ! ( $res = flock( $fh, $locktype | LOCK_NB ) ) |
80 | and |
81 | ++$tries <= $lock_timeout_minutes * 60 / $wait_step_seconds |
82 | ) { |
83 | select( undef, undef, undef, $wait_step_seconds ); |
84 | |
85 | # "say something" every 10 cycles to work around RT#108390 |
86 | # jesus christ our tooling is such a crock of shit :( |
6274881f |
87 | unless ( $tries % 10 ) { |
88 | |
89 | # Turning on autoflush is crucial: if stars align just right buffering |
90 | # will ensure we never actually call write() underneath until the grand |
91 | # timeout is reached (and that's too long). Reproducible via |
92 | # |
93 | # DBICTEST_VERSION_WARNS_INDISCRIMINATELY=1 \ |
94 | # DBICTEST_RUN_ALL_TESTS=1 \ |
95 | # strace -f \ |
96 | # prove -lj10 xt/extra/internals/ |
97 | # |
98 | select( ( select(\*STDOUT), $|=1 )[0] ); |
99 | |
100 | print "#\n"; |
101 | } |
89c7c05d |
102 | } |
103 | |
104 | return $res; |
105 | } |
106 | |
8d6b1478 |
107 | sub local_umask { |
108 | return unless defined $Config{d_umask}; |
109 | |
110 | die 'Calling local_umask() in void context makes no sense' |
111 | if ! defined wantarray; |
112 | |
113 | my $old_umask = umask(shift()); |
114 | die "Setting umask failed: $!" unless defined $old_umask; |
115 | |
116 | return bless \$old_umask, 'DBICTest::Util::UmaskGuard'; |
117 | } |
118 | { |
119 | package DBICTest::Util::UmaskGuard; |
120 | sub DESTROY { |
87f4bab0 |
121 | &DBIx::Class::_Util::detected_reinvoked_destructor; |
122 | |
8d6b1478 |
123 | local ($@, $!); |
124 | eval { defined (umask ${$_[0]}) or die }; |
125 | warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') ) |
126 | if ($@ || $!); |
127 | } |
128 | } |
129 | |
65d35121 |
130 | sub stacktrace { |
131 | my $frame = shift; |
132 | $frame++; |
133 | my (@stack, @frame); |
134 | |
135 | while (@frame = caller($frame++)) { |
136 | push @stack, [@frame[3,1,2]]; |
137 | } |
138 | |
139 | return undef unless @stack; |
140 | |
141 | $stack[0][0] = ''; |
142 | return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; |
143 | } |
144 | |
a3a17a15 |
145 | sub check_customcond_args ($) { |
146 | my $args = shift; |
147 | |
148 | confess "Expecting a hashref" |
149 | unless ref $args eq 'HASH'; |
150 | |
a446d7f8 |
151 | for (qw(rel_name foreign_relname self_alias foreign_alias)) { |
a3a17a15 |
152 | confess "Custom condition argument '$_' must be a plain string" |
153 | if length ref $args->{$_} or ! length $args->{$_}; |
154 | } |
155 | |
a446d7f8 |
156 | confess "Current and legacy rel_name arguments do not match" |
157 | if $args->{rel_name} ne $args->{foreign_relname}; |
158 | |
a3a17a15 |
159 | confess "Custom condition argument 'self_resultsource' must be a rsrc instance" |
160 | unless defined blessed $args->{self_resultsource} and $args->{self_resultsource}->isa('DBIx::Class::ResultSource'); |
161 | |
162 | confess "Passed resultsource has no record of the supplied rel_name - likely wrong \$rsrc" |
a446d7f8 |
163 | unless ref $args->{self_resultsource}->relationship_info($args->{rel_name}); |
164 | |
e884e5d9 |
165 | my $struct_cnt = 0; |
1adbd3fc |
166 | |
98def3ef |
167 | if (defined $args->{self_result_object} or defined $args->{self_rowobj} ) { |
e884e5d9 |
168 | $struct_cnt++; |
98def3ef |
169 | for (qw(self_result_object self_rowobj)) { |
a446d7f8 |
170 | confess "Custom condition argument '$_' must be a result instance" |
171 | unless defined blessed $args->{$_} and $args->{$_}->isa('DBIx::Class::Row'); |
172 | } |
a3a17a15 |
173 | |
98def3ef |
174 | confess "Current and legacy self_result_object arguments do not match" |
175 | if refaddr($args->{self_result_object}) != refaddr($args->{self_rowobj}); |
a3a17a15 |
176 | } |
177 | |
e884e5d9 |
178 | if (defined $args->{foreign_values}) { |
179 | $struct_cnt++; |
1adbd3fc |
180 | |
e884e5d9 |
181 | confess "Custom condition argument 'foreign_values' must be a hash reference" |
182 | unless ref $args->{foreign_values} eq 'HASH'; |
1adbd3fc |
183 | } |
184 | |
e884e5d9 |
185 | confess "Data structures supplied on both ends of a relationship" |
186 | if $struct_cnt == 2; |
1adbd3fc |
187 | |
a3a17a15 |
188 | $args; |
189 | } |
190 | |
2f48c52f |
191 | sub visit_namespaces { |
192 | my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; |
193 | |
194 | my $visited_count = 1; |
195 | |
196 | # A package and a namespace are subtly different things |
197 | $args->{package} ||= 'main'; |
198 | $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x; |
199 | $args->{package} =~ s/^:://; |
200 | |
201 | if ( $args->{action}->($args->{package}) ) { |
202 | my $ns = |
203 | ( ($args->{package} eq 'main') ? '' : $args->{package} ) |
204 | . |
205 | '::' |
206 | ; |
207 | |
208 | $visited_count += visit_namespaces( %$args, package => $_ ) for |
209 | grep |
210 | # this happens sometimes on %:: traversal |
211 | { $_ ne '::main' } |
212 | map |
213 | { $_ =~ /^(.+?)::$/ ? "$ns$1" : () } |
214 | do { no strict 'refs'; keys %$ns } |
215 | ; |
216 | } |
217 | |
218 | return $visited_count; |
219 | } |
220 | |
65d35121 |
221 | 1; |