From: Father Chrysostomos Date: Wed, 24 Sep 2014 08:42:30 +0000 (-0700) Subject: Add lvref magic type X-Git-Tag: v5.21.5~156^2~63 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/9cce4f9a8471c0b7a6994f36be8819352a4d9483?ds=sidebyside 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. --- diff --git a/embed.fnc b/embed.fnc index 9046b38..bceca6b 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 cb6281f..b4176c7 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 9653c70..e271f88 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 52eed71..237dfc5 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 984f1d7..e6bda5d 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 104e936..38ca08e 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 b70ead0..b9ab1e8 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 8fa7f1e..8844932 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 51c1306..3277377 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}]; }