From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 27 Apr 2016 12:57:40 +0000 (+0200)
Subject: Centralize remaining uses of Sub::Name within _Util
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=514b84f6b60b566d75d2ff2ddd08659c4cf7b427;p=dbsrgits%2FDBIx-Class-Historic.git

Centralize remaining uses of Sub::Name within _Util

No functional changes
---

diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
index c5623ca..47eefd5 100644
--- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
@@ -3,11 +3,13 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use Sub::Name ();
-use List::Util ();
 
 use base qw/DBIx::Class::Row/;
 
+use List::Util ();
+use DBIx::Class::_Util 'set_subname';
+use namespace::clean;
+
 __PACKAGE__->mk_classdata('_column_groups' => { });
 
 sub columns {
@@ -111,7 +113,7 @@ sub _register_column_group {
       no strict 'refs';
       no warnings 'redefine';
       my $fullname = join '::', $class, $name;
-      *$fullname = Sub::Name::subname $fullname, $accessor;
+      *$fullname = set_subname $fullname, $accessor;
     }
 
     $our_accessors{$accessor}++;
diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm
index 0022e8a..1c7cf45 100644
--- a/lib/DBIx/Class/ResultSetManager.pm
+++ b/lib/DBIx/Class/ResultSetManager.pm
@@ -2,9 +2,11 @@ package DBIx::Class::ResultSetManager;
 use strict;
 use warnings;
 use base 'DBIx::Class';
-use Sub::Name ();
 use Package::Stash ();
 
+use DBIx::Class::_Util 'set_subname';
+use namespace::clean;
+
 warn "DBIx::Class::ResultSetManager never left experimental status and
 has now been DEPRECATED. This module will be deleted in 09000 so please
 migrate any and all code using it to explicit resultset classes using either
@@ -69,7 +71,7 @@ sub _register_attributes {
             no strict 'refs';
             my $resultset_class = $self->_setup_resultset_class;
             my $name = join '::',$resultset_class, $meth;
-            *$name = Sub::Name::subname $name, $self->can($meth);
+            *$name = set_subname $name, $self->can($meth);
             delete ${"${self}::"}{$meth};
         }
     }
diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm
index 31e39a7..ea69e07 100644
--- a/lib/DBIx/Class/SQLMaker.pm
+++ b/lib/DBIx/Class/SQLMaker.pm
@@ -130,8 +130,8 @@ use base qw/
 /;
 use mro 'c3';
 
-use Sub::Name 'subname';
 use DBIx::Class::Carp;
+use DBIx::Class::_Util 'set_subname';
 use namespace::clean;
 
 __PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
@@ -161,12 +161,12 @@ BEGIN {
   # that use DBIx::Class::Carp/DBIx::Class::Exception instead of plain Carp
   no warnings qw/redefine/;
 
-  *SQL::Abstract::belch = subname 'SQL::Abstract::belch' => sub (@) {
+  *SQL::Abstract::belch = set_subname 'SQL::Abstract::belch' => sub (@) {
     my($func) = (caller(1))[3];
     carp "[$func] Warning: ", @_;
   };
 
-  *SQL::Abstract::puke = subname 'SQL::Abstract::puke' => sub (@) {
+  *SQL::Abstract::puke = set_subname 'SQL::Abstract::puke' => sub (@) {
     my($func) = (caller(1))[3];
     __PACKAGE__->throw_exception("[$func] Fatal: " . join ('',  @_));
   };
diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm
index cfabc73..c7c0621 100644
--- a/lib/DBIx/Class/Storage/DBI/ADO.pm
+++ b/lib/DBIx/Class/Storage/DBI/ADO.pm
@@ -6,8 +6,7 @@ use strict;
 use base 'DBIx::Class::Storage::DBI';
 use mro 'c3';
 
-use Sub::Name;
-use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq );
+use DBIx::Class::_Util qw( sigwarn_silencer modver_gt_or_eq set_subname );
 use namespace::clean;
 
 =head1 NAME
@@ -48,7 +47,7 @@ sub _init {
       no warnings 'redefine';
       my $disconnect = *DBD::ADO::db::disconnect{CODE};
 
-      *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
+      *DBD::ADO::db::disconnect = set_subname 'DBD::ADO::db::disconnect' => sub {
         local $SIG{__WARN__} = sigwarn_silencer(
           qr/Not a Win32::OLE object|uninitialized value/
         );
diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
index a6ff2c7..017709c 100644
--- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
+++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
@@ -11,10 +11,9 @@ use base qw/
 use mro 'c3';
 use DBIx::Class::Carp;
 use Scalar::Util qw/blessed weaken/;
-use Sub::Name();
 use Try::Tiny;
 use Context::Preserve 'preserve_context';
-use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard );
+use DBIx::Class::_Util qw( sigwarn_silencer dbic_internal_try dump_value scope_guard set_subname );
 use namespace::clean;
 
 __PACKAGE__->sql_limit_dialect ('GenericSubQ');
@@ -164,7 +163,7 @@ for my $method (@also_proxy_to_extra_storages) {
 
   my $replaced = __PACKAGE__->can($method);
 
-  *{$method} = Sub::Name::subname $method => sub {
+  *{$method} = set_subname $method => sub {
     my $self = shift;
     $self->_writer_storage->$replaced(@_) if $self->_writer_storage;
     $self->_bulk_storage->$replaced(@_)   if $self->_bulk_storage;
@@ -576,7 +575,7 @@ sub _insert_bulk {
 # This ignores any data conversion errors detected by the client side libs, as
 # they are usually harmless.
   my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
-    Sub::Name::subname _insert_bulk_cslib_errhandler => sub {
+    set_subname _insert_bulk_cslib_errhandler => sub {
       my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
 
       return 1 if $errno == 36;
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index be899ee..f64e04b 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -81,6 +81,7 @@ use Carp 'croak';
 use Storable 'nfreeze';
 use Scalar::Util qw(weaken blessed reftype refaddr);
 use Sub::Quote qw(qsub quote_sub);
+use Sub::Name ();
 
 # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
 BEGIN { *deep_clone = \&Storable::dclone }
@@ -89,7 +90,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
+  refdesc refcount hrefaddr set_subname
   scope_guard detected_reinvoked_destructor
   is_exception dbic_internal_try
   quote_sub qsub perlstring serialize deep_clone dump_value
@@ -133,6 +134,16 @@ sub refcount ($) {
   B::svref_2object($_[0])->REFCNT;
 }
 
+# FIXME In another life switch this to a polyfill like the one in namespace::clean
+sub set_subname ($$) {
+
+  # fully qualify name
+  splice @_, 0, 1, caller(0) . "::$_[0]"
+    if $_[0] !~ /::|'/;
+
+  &Sub::Name::subname;
+}
+
 sub serialize ($) {
   local $Storable::canonical = 1;
   nfreeze($_[0]);
diff --git a/t/72pg.t b/t/72pg.t
index eda3e03..6c2545f 100644
--- a/t/72pg.t
+++ b/t/72pg.t
@@ -7,11 +7,10 @@ use warnings;
 use Test::More;
 use Test::Exception;
 use Test::Warn;
-use Sub::Name;
 use Config;
 use DBICTest;
 use SQL::Abstract 'is_literal_value';
-use DBIx::Class::_Util 'is_exception';
+use DBIx::Class::_Util qw( is_exception set_subname );
 
 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
 
@@ -82,7 +81,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning
 
   no warnings qw/once redefine/;
   my $old_connection = DBICTest::Schema->can('connection');
-  local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+  local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub {
     my $s = shift->$old_connection(@_);
     $s->storage->_use_insert_returning ($use_insert_returning);
     $s;
diff --git a/t/73oracle.t b/t/73oracle.t
index 7d6c790..b61a6a8 100644
--- a/t/73oracle.t
+++ b/t/73oracle.t
@@ -6,8 +6,8 @@ use warnings;
 
 use Test::Exception;
 use Test::More;
-use Sub::Name;
 use Try::Tiny;
+use DBIx::Class::_Util 'set_subname';
 
 use DBICTest;
 
@@ -111,7 +111,7 @@ for my $use_insert_returning ($test_server_supports_insert_returning ? (1,0) : (
 
     no warnings qw/once redefine/;
     my $old_connection = DBICTest::Schema->can('connection');
-    local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
+    local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub {
       my $s = shift->$old_connection (@_);
       $s->storage->_use_insert_returning ($use_insert_returning);
       $s->storage->sql_maker_class('DBIx::Class::SQLMaker::OracleJoins') if $force_ora_joins;
diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t
index a6f6a4e..d067c2b 100644
--- a/t/73oracle_blob.t
+++ b/t/73oracle_blob.t
@@ -6,7 +6,6 @@ use warnings;
 
 use Test::Exception;
 use Test::More;
-use Sub::Name;
 use Try::Tiny;
 
 use DBICTest::Schema::BindType;
diff --git a/t/icdt/engine_specific/sybase.t b/t/icdt/engine_specific/sybase.t
index 993fa9b..f4b8c7b 100644
--- a/t/icdt/engine_specific/sybase.t
+++ b/t/icdt/engine_specific/sybase.t
@@ -6,8 +6,7 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
-use DBIx::Class::_Util 'scope_guard';
-use Sub::Name;
+use DBIx::Class::_Util qw( scope_guard set_subname );
 
 use DBICTest;
 
@@ -123,7 +122,7 @@ SQL
     # UGH!
     {
       no warnings 'once';
-      local *DBICTest::BaseResult::copy = subname 'DBICTest::BaseResult::copy' => sub {
+      local *DBICTest::BaseResult::copy = set_subname 'DBICTest::BaseResult::copy' => sub {
         my $self = shift;
 
         $self->make_column_dirty($_) for keys %{{ $self->get_inflated_columns }};