Add lvref magic type

I just couldn’t resist using the backslash for the character, even
though I had to tweak mg_vtable.pl to make it work.

9 files changed, 44 insertions, 9 deletions

diff --git a/embed.fnc b/embed.fnc
index 9046b38cee..bceca6b224 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -866,6 +866,7 @@ p	|int	|magic_setdefelem|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setenv	|NN SV* sv|NN MAGIC* mg
 dp	|int	|magic_sethint	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setisa	|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_setlvref	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setmglob	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setnkeys	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setpack	|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index cb6281f587..b4176c78c2 100644
--- a/embed.h
+++ b/embed.h
@@ -1227,6 +1227,7 @@
 #define magic_setenv(a,b)	Perl_magic_setenv(aTHX_ a,b)
 #define magic_sethint(a,b)	Perl_magic_sethint(aTHX_ a,b)
 #define magic_setisa(a,b)	Perl_magic_setisa(aTHX_ a,b)
+#define magic_setlvref(a,b)	Perl_magic_setlvref(aTHX_ a,b)
 #define magic_setmglob(a,b)	Perl_magic_setmglob(aTHX_ a,b)
 #define magic_setnkeys(a,b)	Perl_magic_setnkeys(aTHX_ a,b)
 #define magic_setpack(a,b)	Perl_magic_setpack(aTHX_ a,b)
diff --git a/mg.c b/mg.c
index 9653c707e8..e271f883b2 100644
--- a/mg.c
+++ b/mg.c
@@ -2462,6 +2462,14 @@ Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
+Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_SETLVREF;
+    Perl_croak(aTHX_ "Unimplemented");
+    return 0;
+}
+
+int
 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 {
 #ifdef USE_ITHREADS
diff --git a/mg_names.c b/mg_names.c
index 52eed71790..237dfc5b9c 100644
--- a/mg_names.c
+++ b/mg_names.c
@@ -47,6 +47,7 @@
 	{ PERL_MAGIC_utf8,           "utf8(w)" },
 	{ PERL_MAGIC_substr,         "substr(x)" },
 	{ PERL_MAGIC_defelem,        "defelem(y)" },
+	{ PERL_MAGIC_lvref,          "lvref(\\)" },
 	{ PERL_MAGIC_checkcall,      "checkcall(])" },
 	{ PERL_MAGIC_ext,            "ext(~)" },
 
diff --git a/mg_raw.h b/mg_raw.h
index 984f1d7ce5..e6bda5d9a8 100644
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -82,6 +82,8 @@
       "/* substr 'x' substr() lvalue */" },
     { 'y', "want_vtbl_defelem | PERL_MAGIC_VALUE_MAGIC",
       "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" },
+    { '\\', "want_vtbl_lvref",
+      "/* lvref '\\' Lvalue reference in list assignment */" },
     { ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC",
       "/* checkcall ']' inlining/mutation of call to this CV */" },
     { '~', "magic_vtable_max",
diff --git a/mg_vtable.h b/mg_vtable.h
index 104e936cba..38ca08e2b8 100644
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -55,6 +55,7 @@
 #define PERL_MAGIC_substr         'x' /* substr() lvalue */
 #define PERL_MAGIC_defelem        'y' /* Shadow "foreach" iterator variable /
                                          smart parameter vivification */
+#define PERL_MAGIC_lvref          '\\' /* Lvalue reference in list assignment */
 #define PERL_MAGIC_checkcall      ']' /* inlining/mutation of call to this CV */
 #define PERL_MAGIC_ext            '~' /* Available for use by extensions */
 
@@ -73,6 +74,7 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_hintselem,
     want_vtbl_isa,
     want_vtbl_isaelem,
+    want_vtbl_lvref,
     want_vtbl_mglob,
     want_vtbl_nkeys,
     want_vtbl_ovrld,
@@ -108,6 +110,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "hintselem",
     "isa",
     "isaelem",
+    "lvref",
     "mglob",
     "nkeys",
     "ovrld",
@@ -166,6 +169,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, Perl_magic_sethint, 0, Perl_magic_clearhint, 0, 0, 0, 0 },
   { 0, Perl_magic_setisa, 0, Perl_magic_clearisa, 0, 0, 0, 0 },
   { 0, Perl_magic_setisa, 0, 0, 0, 0, 0, 0 },
+  { 0, Perl_magic_setlvref, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setmglob, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getnkeys, Perl_magic_setnkeys, 0, 0, 0, 0, 0, 0 },
   { 0, 0, 0, 0, Perl_magic_freeovrld, 0, 0, 0 },
@@ -210,6 +214,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_hintselem PL_magic_vtables[want_vtbl_hintselem]
 #define PL_vtbl_isa PL_magic_vtables[want_vtbl_isa]
 #define PL_vtbl_isaelem PL_magic_vtables[want_vtbl_isaelem]
+#define PL_vtbl_lvref PL_magic_vtables[want_vtbl_lvref]
 #define PL_vtbl_mglob PL_magic_vtables[want_vtbl_mglob]
 #define PL_vtbl_nkeys PL_magic_vtables[want_vtbl_nkeys]
 #define PL_vtbl_ovrld PL_magic_vtables[want_vtbl_ovrld]
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index b70ead05e1..b9ab1e898f 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1218,6 +1218,8 @@ will be lost.
  y  PERL_MAGIC_defelem        vtbl_defelem   Shadow "foreach" iterator
                                              variable / smart parameter
                                              vivification
+ \  PERL_MAGIC_lvref          vtbl_lvref     Lvalue reference in list
+                                             assignment
  ]  PERL_MAGIC_checkcall      vtbl_checkcall inlining/mutation of call
                                              to this CV
  ~  PERL_MAGIC_ext            (none)         Available for use by
diff --git a/proto.h b/proto.h
index 8fa7f1eb76..88449326f2 100644
--- a/proto.h
+++ b/proto.h
@@ -2514,6 +2514,12 @@ PERL_CALLCONV int	Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_SETISA	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV int	Perl_magic_setlvref(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_SETLVREF	\
+	assert(sv); assert(mg)
+
 PERL_CALLCONV int	Perl_magic_setmglob(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 51c130685b..3277377944 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -25,7 +25,7 @@ BEGIN {
 
 my %mg =
     (
-     sv => { char => '\0', vtable => 'sv', readonly_acceptable => 1,
+     sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1,
 	     desc => 'Special scalar variable' },
      # overload, or type "A" magic, used to be here.  Hence overloaded is
      # often called AMAGIC internally, even though it does not use "A"
@@ -110,6 +110,8 @@ my %mg =
 		    desc => 'inlining/mutation of call to this CV'},
      debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
 		   vtable => 'debugvar' },
+     lvref => { char => '\\', vtable => 'lvref',
+		  desc => "Lvalue reference in list assignment" },
 );
 
 # These have a subtly different "namespace" from the magic types.
@@ -147,6 +149,7 @@ my %sig =
      'hints' => {clear => 'clearhints'},
      'checkcall' => {copy => 'copycallchecker'},
      'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
+     'lvref' => {set => 'setlvref'},
 );
 
 my ($vt, $raw, $names) = map {
@@ -183,39 +186,45 @@ EOH
 
     my %mg_order;
     while (my ($name, $data) = each %mg) {
-	my $byte = eval qq{"$data->{char}"};
-	$data->{byte} = $byte;
+	my $byte = $data->{char};
+	if ($byte =~ /[[:print:]]/) {
+	    $data->{r_char} = $byte; # readable char
+	    ($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings
+	}
+	else {
+	    $data->{c_char} = $data->{r_char} = '\\'.ord $byte;
+	}
 	$mg_order{(uc $byte) . $byte} = $name;
     }
     my @rows;
     foreach (sort keys %mg_order) {
 	my $name = $mg_order{$_};
 	my $data = $mg{$name};
-	my $i = ord $data->{byte};
+	my $i = ord $data->{char};
 	unless ($data->{unknown_to_sv_magic}) {
 	    my $value = $data->{vtable}
 		? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
 	    $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE'
 		if $data->{readonly_acceptable};
 	    $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic};
-	    my $comment = "/* $name '$data->{char}' $data->{desc} */";
+	    my $comment = "/* $name '$data->{r_char}' $data->{desc} */";
 	    $comment =~ s/([\\"])/\\$1/g;
 	    $comment =~ tr/\n/ /;
-	    print $raw qq{    { '$data->{char}', "$value",\n      "$comment" },\n};
+	    print $raw qq{    { '$data->{c_char}', "$value",\n      "$comment" },\n};
 	}
 
 	my $comment = $data->{desc};
 	my $leader = ' ' x ($longest + 27);
 	$comment =~ s/\n/\n$leader/s;
 	printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n",
-	    $name, $data->{char}, $comment;
+	    $name, $data->{c_char}, $comment;
 
-	my $char = $data->{char};
+	my $char = $data->{r_char};
 	$char =~ s/([\\"])/\\$1/g;
 	printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n],
 	    "$name,", $name, $char;
 
-	push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{char}, $name),
+	push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name),
 		     $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)',
 		     $data->{desc}];
     }