X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=f86be002e19b514508cbfe8334c4a499c6ddbe34;hb=7648acb5dd1f2f281ca84e2152efe314bcbf2c70;hp=8bca63519695a601e017d6dc6cef559bce10fa94;hpb=c40b5744f85a8ffc2da494464655936387c04251;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 8bca635..f86be00 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -34,6 +34,8 @@ BEGIN {
 
     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
 
+    TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1
+
     UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
 
     ( map
@@ -173,10 +175,17 @@ use B ();
 use Carp 'croak';
 use Storable 'nfreeze';
 use Scalar::Util qw(weaken blessed reftype refaddr);
-use Sub::Quote qw(qsub);
 use Sub::Name ();
 use attributes ();
 
+# Usually versions are not specified anywhere aside the Makefile.PL
+# (writing them out in-code is extremely obnoxious)
+# However without a recent enough Moo the quote_sub override fails
+# in very puzzling and hard to detect ways: so add a version check
+# just this once
+use Sub::Quote qw(qsub);
+BEGIN { Sub::Quote->VERSION('2.002002') }
+
 # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
 BEGIN { *deep_clone = \&Storable::dclone }
 
@@ -184,7 +193,7 @@ use base 'Exporter';
 our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
   fail_on_internal_wantarray fail_on_internal_call
-  refdesc refcount hrefaddr set_subname describe_class_methods
+  refdesc refcount hrefaddr set_subname get_subname describe_class_methods
   scope_guard detected_reinvoked_destructor emit_loud_diag
   true false
   is_exception dbic_internal_try visit_namespaces
@@ -323,7 +332,14 @@ sub visit_namespaces {
   $visited_count;
 }
 
-# FIXME In another life switch this to a polyfill like the one in namespace::clean
+# FIXME In another life switch these to a polyfill like the ones in namespace::clean
+sub get_subname ($) {
+  my $gv = B::svref_2object( $_[0] )->GV;
+  wantarray
+    ? ( $gv->STASH->NAME, $gv->NAME )
+    : ( join '::', $gv->STASH->NAME, $gv->NAME )
+  ;
+}
 sub set_subname ($$) {
 
   # fully qualify name
@@ -750,6 +766,16 @@ sub modver_gt_or_eq_and_lt ($$$) {
     croak "Expecting a class name either as the sole argument or a 'class' option"
       if not defined $class or $class !~ $module_name_rx;
 
+    croak(
+      "The supplied 'class' argument is tainted: this is *extremely* "
+    . 'dangerous, fix your code ASAP!!! ( for more details read through '
+    . 'https://is.gd/perl_mro_taint_wtf )'
+    ) if (
+      DBIx::Class::_ENV_::TAINT_MODE
+        and
+      Scalar::Util::tainted($class)
+    );
+
     $requested_mro ||= mro::get_mro($class);
 
     # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
@@ -892,7 +918,7 @@ sub modver_gt_or_eq_and_lt ($$$) {
       if (
         ! DBIx::Class::_ENV_::OLD_MRO
           and
-        ${^TAINT}
+        DBIx::Class::_ENV_::TAINT_MODE
       ) {
 
         $slot->{cumulative_gen} = 0;