From: Vincent Pit Date: Mon, 20 Jul 2015 17:12:48 +0000 (-0300) Subject: Delay destruction of reference return values till the current statement end X-Git-Tag: v0.58~8 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=2ccccc5e7ea3f299777e0b67db864a1ea60688a6 Delay destruction of reference return values till the current statement end --- diff --git a/MANIFEST b/MANIFEST index e474b4b..c052756 100644 --- a/MANIFEST +++ b/MANIFEST @@ -39,6 +39,7 @@ t/34-glob.t t/35-stash.t t/40-threads.t t/41-clone.t +t/50-return.t t/80-leaks.t t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm diff --git a/Magic.xs b/Magic.xs index 9eda482..b810d91 100644 --- a/Magic.xs +++ b/Magic.xs @@ -1246,11 +1246,18 @@ static int vmg_cb_call(pTHX_ SV *cb, unsigned int flags, SV *sv, ...) { svr = POPs; if (SvOK(svr)) ret = (int) SvIV(svr); + if (SvROK(svr)) + SvREFCNT_inc(svr); + else + svr = NULL; PUTBACK; FREETMPS; LEAVE; + if (svr && !SvTEMP(svr)) + sv_2mortal(svr); + if (chain) { vmg_dispell_guard_new(*chain); *chain = NULL; diff --git a/lib/Variable/Magic.pm b/lib/Variable/Magic.pm index 12af5b5..7c86649 100644 --- a/lib/Variable/Magic.pm +++ b/lib/Variable/Magic.pm @@ -309,8 +309,12 @@ C<$_[-1]> is the C object for the current op. Both result in a small performance hit, but just getting the name is lighter than getting the op object. -These callbacks are executed in scalar context and are expected to return an integer, which is then passed straight to the perl magic API. -However, only the return value of the I magic callback currently holds a meaning. +These callbacks are always executed in scalar context. +The returned value is coerced into a signed integer, which is then passed straight to the perl magic API. +However, note that perl currently only cares about the return value of the I magic callback and ignores all the others. +Starting with Variable::Magic 0.58, a reference returned from a non-I magic callback will not be destroyed immediately but will be allowed to survive until the end of the statement that triggered the magic. +This lets you use this return value as a token for triggering a destructor after the original magic action takes place. +You can see an example of this technique in the L. =back @@ -577,6 +581,44 @@ When C<%h> goes out of scope, this prints something among the lines of : Of course, this example does nothing with the values that are added after the C. +=head2 Delayed magic actions + +Starting with Variable::Magic 0.58, the return value of the magic callbacks can be used to delay the action until after the original action takes place : + + my $delayed; + my $delayed_aux = wizard( + data => sub { $_[1] }, + free => sub { + my ($target) = $_[1]; + my $target_data = &getdata($target, $delayed); + local $target_data->{guard} = 1; + if (ref $target eq 'SCALAR') { + my $orig = $$target; + $$target = $target_data->{mangler}->($orig); + } + return; + }, + ); + $delayed = wizard( + data => sub { + return +{ guard => 0, mangler => $_[1] }; + }, + set => sub { + return if $_[1]->{guard}; + my $token; + cast $token, $delayed_aux, $_[0]; + return \$token; + }, + ); + my $x = 1; + cast $x, $delayed => sub { $_[0] * 2 }; + $x = 2; + # $x is now 4 + # But note that the delayed action only takes place at the end of the + # current statement : + my @y = ($x = 5, $x); + # $x is now 10, but @y is (5, 5) + =head1 PERL MAGIC HISTORY The places where magic is invoked have changed a bit through perl history. diff --git a/t/50-return.t b/t/50-return.t new file mode 100644 index 0000000..a52d768 --- /dev/null +++ b/t/50-return.t @@ -0,0 +1,195 @@ +#!perl -T + +use strict; +use warnings; + +use Variable::Magic qw; + +use Test::More tests => 3 * 11; + +our $destroyed; + +my $destructor = wizard free => sub { ++$destroyed; return }; + +{ + my $increment; + + my $increment_aux = wizard( + data => sub { $_[1] }, + free => sub { + my ($target) = $_[1]; + my $target_data = &getdata($target, $increment); + local $target_data->{guard} = 1; + ++$$target; + return; + }, + ); + + $increment = wizard( + data => sub { + return +{ guard => 0 }; + }, + set => sub { + return if $_[1]->{guard}; + my $token; + cast $token, $increment_aux, $_[0]; + return \$token; + }, + ); + + local $destroyed = 0; + + { + my $x = 0; + + cast $x, $destructor; + + { + cast $x, $increment; + is $x, 0; + $x = 1; + is $x, 2; + $x = 123; + is $x, 124; + $x = -5; + is $x, -4; + $x = 27, is($x, 27); + is $x, 28; + my @y = ($x = -13, $x); + is $x, -12; + is "@y", '-13 -13'; + } + + dispell $x, $increment; + + $x = 456; + is $x, 456; + + is $destroyed, 0; + } + + is $destroyed, 1; +} + +{ + my $locker; + + my $locker_aux = wizard( + data => sub { $_[1] }, + free => sub { + my ($target) = $_[1]; + my $target_data = &getdata($target, $locker); + local $target_data->{guard} = 1; + $$target = $target_data->{value}; + return; + }, + ); + + $locker = wizard( + data => sub { + return +{ guard => 0, value => $_[1] }; + }, + set => sub { + return if $_[1]->{guard}; + my $token; + cast $token, $locker_aux, $_[0]; + return \$token; + }, + ); + + local $destroyed = 0; + + { + my $x = 0; + + cast $x, $destructor; + + { + cast $x, $locker, 999; + is $x, 0; + $x = 1; + is $x, 999; + $x = 123; + is $x, 999; + $x = -5; + is $x, 999; + $x = 27, is($x, 27); + is $x, 999; + my @y = ($x = -13, $x); + is $x, 999; + is "@y", '-13 -13'; + } + + dispell $x, $locker; + + $x = 456; + is $x, 456; + + is $destroyed, 0; + } + + is $destroyed, 1; +} + +{ + my $delayed; + + my $delayed_aux = wizard( + data => sub { $_[1] }, + free => sub { + my ($target) = $_[1]; + my $target_data = &getdata($target, $delayed); + local $target_data->{guard} = 1; + if (ref $target eq 'SCALAR') { + my $orig = $$target; + $$target = $target_data->{mangler}->($orig); + } + return; + }, + ); + + $delayed = wizard( + data => sub { + return +{ guard => 0, mangler => $_[1] }; + }, + set => sub { + return if $_[1]->{guard}; + my $token; + cast $token, $delayed_aux, $_[0]; + return \$token; + }, + ); + + local $destroyed = 0; + + { + my $x = 0; + + cast $x, $destructor; + + { + cast $x, $delayed => sub { $_[0] * 2 }; + is $x, 0; + $x = 1; + is $x, 2; + $x = 123; + is $x, 246; + $x = -5; + is $x, -10; + $x = 27, is($x, 27); + is $x, 54; + my @y = ($x = -13, $x); + is $x, -26; + is "@y", '-13 -13'; + } + + dispell $x, $delayed; + + $x = 456; + is $x, 456; + + is $destroyed, 0; + } + + is $destroyed, 1; +} diff --git a/t/80-leaks.t b/t/80-leaks.t index 6916936..9ccc1a3 100644 --- a/t/80-leaks.t +++ b/t/80-leaks.t @@ -9,7 +9,7 @@ use Test::More; BEGIN { my $tests = 11; - $tests += 3 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0)); + $tests += 4 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0)); plan tests => $tests; } @@ -115,11 +115,13 @@ $type{$_} = 'scalar_global' for qw; $type{$_} = 'array' for qw; $type{$_} = 'hash' for qw; +sub void { } + my %trigger = ( get => 'my $y = $x', set => '$x = 2', clear => '@a = ()', - free => '', + free => 'void()', local => 'local $X = 2', fetch => 'my $v = $h{a}', store => '$h{a} = 2', @@ -135,16 +137,18 @@ for my $meth (@methods) { my $init = $init{$type{$meth}}; my $trigger = $trigger{$meth}; + my $deinit = ''; if ($meth eq 'free') { - $init = "{\n$init"; - $trigger = '}'; + $init = "{\n$init"; + $deinit = '}'; } my $code = join ";\n", grep length, ( $init, 'is $destroyed, 0, "return from $meth, before trigger"', - $trigger, + $trigger . ', is($destroyed, 0, "return from $meth, after trigger")', + $deinit, 'is $destroyed, 1, "return from $meth, after trigger"', );