Going to be testing the attached patch. It avoids using bless() on <=5.8.8.
From ae0149afbf8f77c574d35c02098f4a45dd147e09 Mon Sep 17 00:00:00 2001
From: Josh ben Jore <jjore@cpan.org>
Date: Thu, 3 Feb 2011 10:23:02 -0800
Subject: [PATCH] Disable overloading in a <=5.8.8 safe way [RT #53700]
---
Changes | 3 +++
lib/Data/Dump/Streamer.pm | 23 +++++++++++++++++------
lib/Data/Dump/Streamer.xs | 26 +++++++++++++++++++++++++-
3 files changed, 45 insertions(+), 7 deletions(-)
diff --git a/Changes b/Changes
index 370e910..12c1969 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,6 @@
+...
+Disable overloading in a <=5.8.8 safe way
+
2.31
React to Strawberry perl $. strangeness [RT #58528]
diff --git a/lib/Data/Dump/Streamer.pm b/lib/Data/Dump/Streamer.pm
index 28d37b0..88f5cb2 100644
--- a/lib/Data/Dump/Streamer.pm
+++ b/lib/Data/Dump/Streamer.pm
@@ -206,6 +206,17 @@ EO_HU
};
*lock_keys_plus=sub(\%;@){lock_ref_keys_plus(@_)};
}
+ if ($] <= 5.008008) {
+ *disable_overloading = \&SvAMAGIC_off;
+ *restore_overloading = \&SvAMAGIC_on;
+ } else {
+ *disable_overloading = sub ($) {
+ bless $_[0], 'Does::Not::Exist';
+ };
+ *restore_overloading = sub ($$) {
+ bless $_[0], $_[1];
+ };
+ }
my %fail=map { ( $_ => 1 ) } @EXPORT_FAIL;
@EXPORT_OK=grep { !$fail{$_} } @EXPORT_OK;
}
@@ -1526,7 +1537,7 @@ PASS:{
my $overloaded=undef;
my $isoverloaded=0;
if (defined $class and overload::Overloaded($item)) {
- bless $item, 'Does::Not::Exist';
+ disable_overloading( $item );
$overloaded= $class;
$isoverloaded= 1;
}
@@ -1639,7 +1650,7 @@ PASS:{
if $ENV{DDS_STRICT};
}
if ($isoverloaded) {
- $item= bless $item, $overloaded;
+ restore_overloading( $item, $overloaded );
}
}
if ( $pass++ == 1 ) {
@@ -1865,7 +1876,7 @@ sub _dump_apply_fix { #handle fix statements and GLOB's here.
overload::Overloaded( $lhs ) )
{
$overloaded=blessed $lhs;
- bless $lhs,"Does::Not::Exist";
+ disable_overloading( $lhs );
$isoverloaded=1;
}
foreach my $t ($self->_glob_slots(''))
@@ -1926,7 +1937,7 @@ sub _dump_apply_fix { #handle fix statements and GLOB's here.
}
}
if ($isoverloaded) {
- $lhs=bless $lhs,$overloaded;
+ restore_overloading( $lhs, $overloaded );
}
@@ -2887,7 +2898,7 @@ sub _dump_rv {
}
my $isoverloaded=0;
if (defined $class and overload::Overloaded($item)) {
- bless $item, 'Does::Not::Exist';
+ disable_overloading( $item );
$overloaded= $class;
$isoverloaded= 1;
}
@@ -2968,7 +2979,7 @@ sub _dump_rv {
$self->_add_fix('bless',$idx,$overloaded);
}
if ($isoverloaded) {
- $item=bless $item, $overloaded;
+ restore_overloading( $item, $overloaded );
}
}
if ($fix_lock && !defined($class)) {
diff --git a/lib/Data/Dump/Streamer.xs b/lib/Data/Dump/Streamer.xs
index 6af81df..c4ff2eb 100644
--- a/lib/Data/Dump/Streamer.xs
+++ b/lib/Data/Dump/Streamer.xs
@@ -107,6 +107,12 @@ my_cxinc(pTHX)
# define NV double
#endif
+#if PERL_VERSION < 8
+# define MY_XS_AMAGIC
+#endif
+#if ((PERL_VERSION == 8) && (PERL_SUBVERSION <= 8))
+# define MY_XS_AMAGIC
+#endif
/*
the following three subs are outright stolen from Data::Dumper ( Dumper.xs )
@@ -180,7 +186,6 @@ esc_q(register char *d, register char *s, register STRLEN slen)
return ret;
}
-
XS(XS_Data__Dump__Streamer_SvREADONLY);
XS(XS_Data__Dump__Streamer_SvREADONLY) /* This is dangerous stuff. */
{
@@ -768,6 +773,25 @@ CODE:
OUTPUT:
RETVAL
+#ifdef MY_XS_AMAGIC
+
+void
+SvAMAGIC_off(sv)
+ SV * sv
+PROTOTYPE: $
+CODE:
+ SvAMAGIC_off(sv)
+
+void
+SvAMAGIC_on(sv,klass)
+ SV * sv
+ SV * klass
+PROTOTYPE: $
+CODE:
+ SvAMAGIC_off(sv)
+
+#endif
+
#ifndef NEW_REGEX_ENGINE
--
1.7.1
