Add VMG_COMPAT_SCALAR_NOLEN

Starting from perl 5.17.4, perl no longer calls 'len' magic on scalars.
This new compatibility macro reflects this change.

This fixes RT #80388.

diff --git a/Magic.xs b/Magic.xs
index 9bdcca5b61643abb21f021890247bf1cf2e8b56e..c199f7eb2e5847a3e411c4c9b32fe73f3a46073a 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -139,6 +139,12 @@
 # define VMG_COMPAT_SCALAR_LENGTH_NOLEN 0
 #endif
 
+#if VMG_HAS_PERL(5, 17, 4)
+# define VMG_COMPAT_SCALAR_NOLEN 1
+#else
+# define VMG_COMPAT_SCALAR_NOLEN 0
+#endif
+
 /* Applied to dev-5.9 as 25854, integrated to maint-5.8 as 28160, partially
  * reverted to dev-5.11 as 9cdcb38b */
 #if VMG_HAS_PERL_MAINT(5, 8, 9, 28160) || VMG_HAS_PERL_MAINT(5, 9, 3, 25854) || VMG_HAS_PERL(5, 10, 0)
@@ -1799,6 +1805,8 @@ BOOT:
  newCONSTSUB(stash, "VMG_UVAR",  newSVuv(VMG_UVAR));
  newCONSTSUB(stash, "VMG_COMPAT_SCALAR_LENGTH_NOLEN",
                     newSVuv(VMG_COMPAT_SCALAR_LENGTH_NOLEN));
+ newCONSTSUB(stash, "VMG_COMPAT_SCALAR_NOLEN",
+                    newSVuv(VMG_COMPAT_SCALAR_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN",
                     newSVuv(VMG_COMPAT_ARRAY_PUSH_NOLEN));
  newCONSTSUB(stash, "VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID",

diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm
index 2fe47c920388b748a0e41f74f87ddf6ec956c190..47ed91a7577769e62c72ef9304902d2a657252e3 100644 (file)
--- a/lib/Variable/Magic.pm
+++ b/lib/Variable/Magic.pm
@@ -127,10 +127,13 @@ It is called for array subscripts and slices, but never for hashes.
 
 I<len>
 
-This magic only applies to scalars and arrays, and is triggered when the 'size' or the 'length' of the variable has to be known by Perl.
+This magic only applies to arrays (though it used to also apply to scalars), and is triggered when the 'size' or the 'length' of the variable has to be known by Perl.
 This is typically the magic involved when an array is evaluated in scalar context, but also on array assignment and loops (C<for>, C<map> or C<grep>).
 The length is returned from the callback as an integer.
 
+Starting from perl 5.12, this magic is no longer called by the C<length> keyword, and starting from perl 5.17.4 it is also no longer called for scalars in any situation, making this magic only meaningful on arrays.
+You can use the constants L</VMG_COMPAT_SCALAR_LENGTH_NOLEN> and L</VMG_COMPAT_SCALAR_NOLEN> to see if this magic is available for scalars or not.
+
 =item *
 
 I<clear>
@@ -434,6 +437,11 @@ Initial L</VMG_UVAR> capability was introduced in perl 5.9.5, with a fully funct
 
 True for perls that don't call I<len> magic when taking the C<length> of a magical scalar.
 
+=head2 C<VMG_COMPAT_SCALAR_NOLEN>
+
+True for perls that don't call I<len> magic on scalars.
+Implies L</VMG_COMPAT_SCALAR_LENGTH_NOLEN>.
+
 =head2 C<VMG_COMPAT_ARRAY_PUSH_NOLEN>
 
 True for perls that don't call I<len> magic when you push an element in a magical array.
@@ -633,6 +641,7 @@ our %EXPORT_TAGS    = (
  'consts' => [ qw<
    MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
    VMG_COMPAT_SCALAR_LENGTH_NOLEN
+   VMG_COMPAT_SCALAR_NOLEN
    VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
    VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
    VMG_COMPAT_ARRAY_UNDEF_CLEAR

diff --git a/t/01-import.t b/t/01-import.t
index 17fdc46d68222b7058f7160bf270d283ccd5fd71..f6d41d081f24e820894ee3c02943cb5f5d91a011 100644 (file)
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2 * 20;
+use Test::More tests => 2 * 21;
 
 require Variable::Magic;
 
@@ -15,6 +15,7 @@ my %syms = (
  map { $_ => '' } qw<
   MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR
   VMG_COMPAT_SCALAR_LENGTH_NOLEN
+  VMG_COMPAT_SCALAR_NOLEN
   VMG_COMPAT_ARRAY_PUSH_NOLEN VMG_COMPAT_ARRAY_PUSH_NOLEN_VOID
   VMG_COMPAT_ARRAY_UNSHIFT_NOLEN_VOID
   VMG_COMPAT_ARRAY_UNDEF_CLEAR

diff --git a/t/22-len.t b/t/22-len.t
index ab19730c7492c0a653070b3f8365b8c581b3a80f..6f556e672f7e9b1cc59f85a151161476637976fc 100644 (file)
--- a/t/22-len.t
+++ b/t/22-len.t
@@ -5,7 +5,10 @@ use warnings;
 
 use Test::More tests => 39 + (2 * 2 + 1) + (5 + 2 * 3);
 
-use Variable::Magic qw<wizard cast dispell VMG_COMPAT_SCALAR_LENGTH_NOLEN>;
+use Variable::Magic qw<
+ wizard cast dispell
+ VMG_COMPAT_SCALAR_LENGTH_NOLEN VMG_COMPAT_SCALAR_NOLEN
+>;
 
 use lib 't/lib';
 use Variable::Magic::TestValue;
@@ -65,95 +68,101 @@ is $d, 0,  'len: get last empty array index have correct default length';
 is $b, -1, 'len: get last empty array index correctly';
 
 SKIP: {
- skip 'length() no longer calls mg_len magic' => 16 if VMG_COMPAT_SCALAR_LENGTH_NOLEN;
-
- $c = 0;
- $n = 1 + int rand 1000;
- # length magic on scalars needs also get magic to be triggered.
- my $wiz = wizard get => sub { return 'anything' },
-                  len => sub { $d = $_[2]; ++$c; return $n };
-
- my $x = 6789;
-
- $c = 0;
- cast $x, $wiz;
- is $c, 0, 'len: cast on scalar doesn\'t trigger magic';
-
- $c = 0;
- $d = undef;
- $b = length $x;
- is $c, 1,  'len: get scalar length triggers magic correctly';
- is $d, 4,  'len: get scalar length have correct default length';
- is $b, $n, 'len: get scalar length correctly';
-
- $n = 0;
-
- $c = 0;
- $d = undef;
- $b = length $x;
- is $c, 1,  'len: get scalar length 0 triggers magic correctly';
- is $d, 4,  'len: get scalar length 0 have correct default length';
- is $b, $n, 'len: get scalar length 0 correctly';
-
- $n = undef;
- $x = '';
- cast $x, $wiz;
-
- $c = 0;
- $d = undef;
- $b = length $x;
- is $c, 1, 'len: get empty scalar length triggers magic correctly';
- is $d, 0, 'len: get empty scalar length have correct default length';
- is $b, 0, 'len: get empty scalar length correctly';
-
- $x = "\x{20AB}ongs";
- cast $x, $wiz;
+ skip 'len magic is no longer called for scalars' => 16 + 6
+                                                     if VMG_COMPAT_SCALAR_NOLEN;
 
- {
-  use bytes;
+ SKIP: {
+  skip 'length() no longer calls len magic on plain scalars' => 16
+                                              if VMG_COMPAT_SCALAR_LENGTH_NOLEN;
+
+  $c = 0;
+  $n = 1 + int rand 1000;
+  # length magic on scalars needs also get magic to be triggered.
+  my $wiz = wizard get => sub { return 'anything' },
+                   len => sub { $d = $_[2]; ++$c; return $n };
+
+  my $x = 6789;
+
+  $c = 0;
+  cast $x, $wiz;
+  is $c, 0, 'len: cast on scalar doesn\'t trigger magic';
 
   $c = 0;
   $d = undef;
   $b = length $x;
-  is $c, 1,  'len: get utf8 scalar length in bytes triggers magic correctly';
-  is $d, 7,  'len: get utf8 scalar length in bytes have correct default length';
-  is $b, $d, 'len: get utf8 scalar length in bytes correctly';
- }
+  is $c, 1,  'len: get scalar length triggers magic correctly';
+  is $d, 4,  'len: get scalar length have correct default length';
+  is $b, $n, 'len: get scalar length correctly';
 
- $c = 0;
- $d = undef;
- $b = length $x;
- is $c, 1,  'len: get utf8 scalar length triggers magic correctly';
- is $d, 5,  'len: get utf8 scalar length have correct default length';
- is $b, $d, 'len: get utf8 scalar length correctly';
-}
+  $n = 0;
 
-{
- our $c;
- # length magic on scalars needs also get magic to be triggered.
- my $wiz = wizard get => sub { 0 },
-                  len => sub { $d = $_[2]; ++$c; return $_[2] };
+  $c = 0;
+  $d = undef;
+  $b = length $x;
+  is $c, 1,  'len: get scalar length 0 triggers magic correctly';
+  is $d, 4,  'len: get scalar length 0 have correct default length';
+  is $b, $n, 'len: get scalar length 0 correctly';
 
- {
-  my $x = "banana";
+  $n = undef;
+  $x = '';
   cast $x, $wiz;
 
-  local $c = 0;
-  pos($x) = 2;
-  is $c, 1,        'len: pos scalar triggers magic correctly';
-  is $d, 6,        'len: pos scalar have correct default length';
-  is $x, 'banana', 'len: pos scalar works correctly'
- }
+  $c = 0;
+  $d = undef;
+  $b = length $x;
+  is $c, 1, 'len: get empty scalar length triggers magic correctly';
+  is $d, 0, 'len: get empty scalar length have correct default length';
+  is $b, 0, 'len: get empty scalar length correctly';
 
- {
-  my $x = "hl\x{20AB}gh"; # Force utf8 on string
+  $x = "\x{20AB}ongs";
   cast $x, $wiz;
 
-  local $c = 0;
-  substr($x, 2, 1) = 'a';
-  is $c, 1,       'len: substr utf8 scalar triggers magic correctly';
-  is $d, 5,       'len: substr utf8 scalar have correct default length';
-  is $x, 'hlagh', 'len: substr utf8 scalar correctly';
+  {
+   use bytes;
+
+   $c = 0;
+   $d = undef;
+   $b = length $x;
+   is $c, 1, 'len: get utf8 scalar length in bytes triggers magic correctly';
+   is $d, 7, 'len: get utf8 scalar length in bytes have correct default length';
+   is $b, $d,'len: get utf8 scalar length in bytes correctly';
+  }
+
+  $c = 0;
+  $d = undef;
+  $b = length $x;
+  is $c, 1,  'len: get utf8 scalar length triggers magic correctly';
+  is $d, 5,  'len: get utf8 scalar length have correct default length';
+  is $b, $d, 'len: get utf8 scalar length correctly';
+ }
+
+ {
+  our $c;
+  # length magic on scalars needs also get magic to be triggered.
+  my $wiz = wizard get => sub { 0 },
+                   len => sub { $d = $_[2]; ++$c; return $_[2] };
+
+  {
+   my $x = "banana";
+   cast $x, $wiz;
+
+   local $c = 0;
+   pos($x) = 2;
+   is $c, 1,        'len: pos scalar triggers magic correctly';
+   is $d, 6,        'len: pos scalar have correct default length';
+   is $x, 'banana', 'len: pos scalar works correctly'
+  }
+
+  {
+   my $x = "hl\x{20AB}gh"; # Force utf8 on string
+   cast $x, $wiz;
+
+   local $c = 0;
+   substr($x, 2, 1) = 'a';
+   is $c, 1,       'len: substr utf8 scalar triggers magic correctly';
+   is $d, 5,       'len: substr utf8 scalar have correct default length';
+   is $x, 'hlagh', 'len: substr utf8 scalar correctly';
+  }
  }
 }