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