'undef =>' isn't what one would want
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / _Util.pm
CommitLineData
b1dbf716 1package # hide from PAUSE
2 DBIx::Class::_Util;
3
4use warnings;
5use strict;
6
7use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0);
8
37873f78 9BEGIN {
10 package # hide from pause
11 DBIx::Class::_ENV_;
12
13 use Config;
14
15 use constant {
16
17 # but of course
18 BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0,
19
8d73fcd4 20 BROKEN_GOTO => ($] < '5.008003') ? 1 : 0,
21
37873f78 22 HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
23
24 # ::Runmode would only be loaded by DBICTest, which in turn implies t/
25 DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0,
26
27 # During 5.13 dev cycle HELEMs started to leak on copy
6cfb1d2f 28 # add an escape for these perls ON SMOKERS - a user will still get death
29 PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ),
37873f78 30
1b658919 31 SHUFFLE_UNORDERED_RESULTSETS => $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} ? 1 : 0,
32
37873f78 33 ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
34
77c3a5dc 35 ASSERT_NO_INTERNAL_INDIRECT_CALLS => $ENV{DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0,
36
2fdeef65 37 STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE => $ENV{DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0,
38
f45dc928 39 STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE => $ENV{DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE} ? 1 : 0,
40
37873f78 41 IV_SIZE => $Config{ivsize},
00882d2c 42
43 OS_NAME => $^O,
37873f78 44 };
45
46 if ($] < 5.009_005) {
47 require MRO::Compat;
48 constant->import( OLD_MRO => 1 );
49 }
50 else {
51 require mro;
52 constant->import( OLD_MRO => 0 );
53 }
54}
55
841efcb3 56# FIXME - this is not supposed to be here
57# Carp::Skip to the rescue soon
58use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
59
d7d45bdc 60use B ();
841efcb3 61use Carp 'croak';
d7d45bdc 62use Storable 'nfreeze';
3d56e026 63use Scalar::Util qw(weaken blessed reftype refaddr);
3705e3b2 64use List::Util qw(first);
0020e364 65use Sub::Quote qw(qsub quote_sub);
7f9a3f70 66
1c30a2e4 67# Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
68BEGIN { *deep_clone = \&Storable::dclone }
69
b1dbf716 70use base 'Exporter';
3705e3b2 71our @EXPORT_OK = qw(
d634850b 72 sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
77c3a5dc 73 fail_on_internal_wantarray fail_on_internal_call
3d56e026 74 refdesc refcount hrefaddr is_exception detect_reinvoked_destructor
1c30a2e4 75 quote_sub qsub perlstring serialize deep_clone
facd0e8e 76 UNRESOLVABLE_CONDITION
3705e3b2 77);
052a832c 78
facd0e8e 79use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
80
bf302897 81sub sigwarn_silencer ($) {
052a832c 82 my $pattern = shift;
83
84 croak "Expecting a regexp" if ref $pattern ne 'Regexp';
85
86 my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
87
88 return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
89}
b1dbf716 90
01b25f12 91sub perlstring ($) { q{"}. quotemeta( shift ). q{"} };
92
3d56e026 93sub hrefaddr ($) { sprintf '0x%x', &refaddr||0 }
8433421f 94
95sub refdesc ($) {
96 croak "Expecting a reference" if ! length ref $_[0];
97
98 # be careful not to trigger stringification,
99 # reuse @_ as a scratch-pad
100 sprintf '%s%s(0x%x)',
101 ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ),
102 reftype $_[0],
3d56e026 103 refaddr($_[0]),
8433421f 104 ;
105}
bf302897 106
107sub refcount ($) {
dac7972a 108 croak "Expecting a reference" if ! length ref $_[0];
109
dac7972a 110 # No tempvars - must operate on $_[0], otherwise the pad
111 # will count as an extra ref
112 B::svref_2object($_[0])->REFCNT;
113}
114
b34d9331 115sub serialize ($) {
b34d9331 116 local $Storable::canonical = 1;
d7d45bdc 117 nfreeze($_[0]);
b34d9331 118}
119
841efcb3 120sub is_exception ($) {
121 my $e = $_[0];
122
a0414138 123 # this is not strictly correct - an eval setting $@ to undef
124 # is *not* the same as an eval setting $@ to ''
125 # but for the sake of simplicity assume the following for
126 # the time being
127 return 0 unless defined $e;
128
841efcb3 129 my ($not_blank, $suberror);
130 {
131 local $@;
132 eval {
133 $not_blank = ($e ne '') ? 1 : 0;
134 1;
135 } or $suberror = $@;
136 }
137
138 if (defined $suberror) {
139 if (length (my $class = blessed($e) )) {
140 carp_unique( sprintf(
9bea2000 141 'External exception class %s implements partial (broken) overloading '
142 . 'preventing its instances from being used in simple ($x eq $y) '
841efcb3 143 . 'comparisons. Given Perl\'s "globally cooperative" exception '
144 . 'handling this type of brokenness is extremely dangerous on '
145 . 'exception objects, as it may (and often does) result in silent '
146 . '"exception substitution". DBIx::Class tries to work around this '
147 . 'as much as possible, but other parts of your software stack may '
148 . 'not be even aware of this. Please submit a bugreport against the '
149 . 'distribution containing %s and in the meantime apply a fix similar '
150 . 'to the one shown at %s, in order to ensure your exception handling '
151 . 'is saner application-wide. What follows is the actual error text '
152 . "as generated by Perl itself:\n\n%s\n ",
9bea2000 153 $class,
841efcb3 154 $class,
155 'http://v.gd/DBIC_overload_tempfix/',
156 $suberror,
157 ));
158
159 # workaround, keeps spice flowing
160 $not_blank = ("$e" ne '') ? 1 : 0;
161 }
162 else {
163 # not blessed yet failed the 'ne'... this makes 0 sense...
164 # just throw further
165 die $suberror
166 }
167 }
168
169 return $not_blank;
170}
171
3d56e026 172{
173 my $destruction_registry = {};
174
175 sub CLONE {
176 $destruction_registry = { map
177 { defined $_ ? ( refaddr($_) => $_ ) : () }
178 values %$destruction_registry
179 };
180 }
181
182 # This is almost invariably invoked from within DESTROY
183 # throwing exceptions won't work
184 sub detect_reinvoked_destructor {
185
186 # quick "garbage collection" pass - prevents the registry
187 # from slowly growing with a bunch of undef-valued keys
188 defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
189 for keys %$destruction_registry;
190
191 unless (length ref $_[0]) {
192 printf STDERR '%s() expects a reference %s',
193 (caller(0))[3],
194 Carp::longmess,
195 ;
196 return undef; # don't know wtf to do
197 }
198
199 if (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
200 weaken( $destruction_registry->{$addr} = $_[0] );
201 return 0;
202 }
203 else {
204 carp_unique ( sprintf (
205 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
206 . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
207 . 'application, affecting *ALL* classes without active protection against '
208 . 'this. Diagnose and fix the root cause ASAP!!!%s',
209 refdesc $_[0],
210 ( ( $INC{'Devel/StackTrace.pm'} and ! do { local $@; eval { Devel::StackTrace->VERSION(2) } } )
211 ? " (likely culprit Devel::StackTrace\@@{[ Devel::StackTrace->VERSION ]} found in %INC, http://is.gd/D_ST_refcap)"
212 : ''
213 )
214 ));
215
216 return 1;
217 }
218 }
219}
220
bf302897 221sub modver_gt_or_eq ($$) {
b1dbf716 222 my ($mod, $ver) = @_;
223
224 croak "Nonsensical module name supplied"
225 if ! defined $mod or ! length $mod;
226
227 croak "Nonsensical minimum version supplied"
228 if ! defined $ver or $ver =~ /[^0-9\.\_]/;
229
052a832c 230 local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
231 if SPURIOUS_VERSION_CHECK_WARNINGS;
b1dbf716 232
56270bba 233 croak "$mod does not seem to provide a version (perhaps it never loaded)"
234 unless $mod->VERSION;
235
b1dbf716 236 local $@;
237 eval { $mod->VERSION($ver) } ? 1 : 0;
238}
239
d634850b 240sub modver_gt_or_eq_and_lt ($$$) {
241 my ($mod, $v_ge, $v_lt) = @_;
242
243 croak "Nonsensical maximum version supplied"
244 if ! defined $v_lt or $v_lt =~ /[^0-9\.\_]/;
245
246 return (
247 modver_gt_or_eq($mod, $v_ge)
248 and
249 ! modver_gt_or_eq($mod, $v_lt)
250 ) ? 1 : 0;
251}
252
a9da9b6a 253{
254 my $list_ctx_ok_stack_marker;
255
e89c7968 256 sub fail_on_internal_wantarray () {
a9da9b6a 257 return if $list_ctx_ok_stack_marker;
258
259 if (! defined wantarray) {
260 croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
261 }
262
263 my $cf = 1;
264 while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?:
265
266 # these are public API parts that alter behavior on wantarray
267 search | search_related | slice | search_literal
268
269 |
270
271 # these are explicitly prefixed, since we only recognize them as valid
272 # escapes when they come from the guts of CDBICompat
273 CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
274
275 ) $/x ) {
276 $cf++;
277 }
278
e89c7968 279 my ($fr, $want, $argdesc);
280 {
281 package DB;
282 $fr = [ caller($cf) ];
283 $want = ( caller($cf-1) )[5];
284 $argdesc = ref $DB::args[0]
285 ? DBIx::Class::_Util::refdesc($DB::args[0])
286 : 'non '
287 ;
288 };
289
a9da9b6a 290 if (
e89c7968 291 $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
a9da9b6a 292 ) {
a9da9b6a 293 DBIx::Class::Exception->throw( sprintf (
e89c7968 294 "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts",
295 $argdesc, @{$fr}[1,2]
a9da9b6a 296 ), 'with_stacktrace');
297 }
298
299 my $mark = [];
300 weaken ( $list_ctx_ok_stack_marker = $mark );
301 $mark;
302 }
303}
304
77c3a5dc 305sub fail_on_internal_call {
306 my ($fr, $argdesc);
307 {
308 package DB;
309 $fr = [ caller(1) ];
310 $argdesc = ref $DB::args[0]
311 ? DBIx::Class::_Util::refdesc($DB::args[0])
312 : undef
313 ;
314 };
315
316 if (
317 $argdesc
318 and
319 $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
320 and
321 $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there
322 ) {
323 DBIx::Class::Exception->throw( sprintf (
324 "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts",
325 $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
326 require B::Deparse;
327 no strict 'refs';
328 B::Deparse->new->coderef2text(\&{$fr->[3]})
329 }),
330 ), 'with_stacktrace');
331 }
332}
333
b1dbf716 3341;