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