Add lvref magic type
authorFather Chrysostomos <sprout@cpan.org>
Wed, 24 Sep 2014 08:42:30 +0000 (01:42 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 11 Oct 2014 04:55:09 +0000 (21:55 -0700)
I just couldn’t resist using the backslash for the character, even
though I had to tweak mg_vtable.pl to make it work.

embed.fnc
embed.h
mg.c
mg_names.c
mg_raw.h
mg_vtable.h
pod/perlguts.pod
proto.h
regen/mg_vtable.pl

index 9046b38..bceca6b 100644 (file)
--- 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 cb6281f..b4176c7 100644 (file)
--- a/embed.h
+++ b/embed.h
 #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 9653c70..e271f88 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2461,6 +2461,14 @@ Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+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)
 {
index 52eed71..237dfc5 100644 (file)
@@ -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(~)" },
 
index 984f1d7..e6bda5d 100644 (file)
--- 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",
index 104e936..38ca08e 100644 (file)
@@ -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]
index b70ead0..b9ab1e8 100644 (file)
@@ -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 8fa7f1e..8844932 100644 (file)
--- 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);
index 51c1306..3277377 100644 (file)
@@ -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}];
     }