Hello community,
here is the log from the commit of package perl-Variable-Magic for
openSUSE:Factory checked in at 2015-07-23 15:22:45
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/perl-Variable-Magic (Old)
and /work/SRC/openSUSE:Factory/.perl-Variable-Magic.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "perl-Variable-Magic"
Changes:
--------
--- /work/SRC/openSUSE:Factory/perl-Variable-Magic/perl-Variable-Magic.changes
2015-04-18 10:41:10.000000000 +0200
+++
/work/SRC/openSUSE:Factory/.perl-Variable-Magic.new/perl-Variable-Magic.changes
2015-07-23 15:23:00.000000000 +0200
@@ -1,0 +2,16 @@
+Wed Jul 22 09:30:21 UTC 2015 - [email protected]
+
+- updated to 0.58
+ see /usr/share/doc/packages/perl-Variable-Magic/Changes
+
+ 0.58 2015-07-21 16:00 UTC
+ + Add : If a non-len magic callback returns a reference, it will now
+ only be freed at the end of the statement that caused the
+ magic to trigger. This allows the user to attach free magic
+ (or a plain destructor) to a token returned from the
callbacks
+ in order to defer an action after the magic is processed by
+ perl.
+ + Fix : Test failures of threads tests on systems with harsh resource
+ constraints causing the threads to exit() during run.
+
+-------------------------------------------------------------------
Old:
----
Variable-Magic-0.57.tar.gz
New:
----
Variable-Magic-0.58.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ perl-Variable-Magic.spec ++++++
--- /var/tmp/diff_new_pack.yMBkgX/_old 2015-07-23 15:23:00.000000000 +0200
+++ /var/tmp/diff_new_pack.yMBkgX/_new 2015-07-23 15:23:00.000000000 +0200
@@ -17,7 +17,7 @@
Name: perl-Variable-Magic
-Version: 0.57
+Version: 0.58
Release: 0
%define cpan_name Variable-Magic
Summary: Associate user-defined magic to variables from Perl
++++++ Variable-Magic-0.57.tar.gz -> Variable-Magic-0.58.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/Changes
new/Variable-Magic-0.58/Changes
--- old/Variable-Magic-0.57/Changes 2015-04-17 16:57:18.000000000 +0200
+++ new/Variable-Magic-0.58/Changes 2015-07-21 17:41:49.000000000 +0200
@@ -1,5 +1,15 @@
Revision history for Variable-Magic
+0.58 2015-07-21 16:00 UTC
+ + Add : If a non-len magic callback returns a reference, it will now
+ only be freed at the end of the statement that caused the
+ magic to trigger. This allows the user to attach free magic
+ (or a plain destructor) to a token returned from the callbacks
+ in order to defer an action after the magic is processed by
+ perl.
+ + Fix : Test failures of threads tests on systems with harsh resource
+ constraints causing the threads to exit() during run.
+
0.57 2015-04-17 15:20 UTC
+ Chg : The new environment variable to enable thread tests on older
perls is PERL_FORCE_TEST_THREADS. Note that this variable
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/MANIFEST
new/Variable-Magic-0.58/MANIFEST
--- old/Variable-Magic-0.57/MANIFEST 2015-03-28 01:38:33.000000000 +0100
+++ new/Variable-Magic-0.58/MANIFEST 2015-07-21 17:35:40.000000000 +0200
@@ -39,6 +39,7 @@
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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/META.json
new/Variable-Magic-0.58/META.json
--- old/Variable-Magic-0.57/META.json 2015-04-17 16:59:24.000000000 +0200
+++ new/Variable-Magic-0.58/META.json 2015-07-21 17:42:56.000000000 +0200
@@ -4,7 +4,7 @@
"Vincent Pit <[email protected]>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter
version 2.150001",
+ "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter
version 2.150005",
"license" : [
"perl_5"
],
@@ -66,5 +66,6 @@
"url" :
"http://git.profvince.com/?p=perl%2Fmodules%2FVariable-Magic.git";
}
},
- "version" : "0.57"
+ "version" : "0.58",
+ "x_serialization_backend" : "JSON::PP version 2.27300"
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/META.yml
new/Variable-Magic-0.58/META.yml
--- old/Variable-Magic-0.57/META.yml 2015-04-17 16:59:24.000000000 +0200
+++ new/Variable-Magic-0.58/META.yml 2015-07-21 17:42:55.000000000 +0200
@@ -20,7 +20,7 @@
Config: '0'
ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version
2.150001'
+generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter
version 2.150005'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -41,4 +41,5 @@
homepage: http://search.cpan.org/dist/Variable-Magic/
license: http://dev.perl.org/licenses/
repository: http://git.profvince.com/?p=perl%2Fmodules%2FVariable-Magic.git
-version: '0.57'
+version: '0.58'
+x_serialization_backend: 'CPAN::Meta::YAML version 0.016'
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/Magic.xs
new/Variable-Magic-0.58/Magic.xs
--- old/Variable-Magic-0.57/Magic.xs 2015-04-14 19:00:58.000000000 +0200
+++ new/Variable-Magic-0.58/Magic.xs 2015-07-21 17:35:40.000000000 +0200
@@ -488,9 +488,8 @@
/* --- Error messages ------------------------------------------------------ */
-static const char vmg_invalid_wiz[] = "Invalid wizard object";
-static const char vmg_wrongargnum[] = "Wrong number of arguments";
-static const char vmg_argstorefailed[] = "Error while storing arguments";
+static const char vmg_invalid_wiz[] = "Invalid wizard object";
+static const char vmg_wrongargnum[] = "Wrong number of arguments";
/* --- Context-safe global data -------------------------------------------- */
@@ -1246,11 +1245,18 @@
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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/README
new/Variable-Magic-0.58/README
--- old/Variable-Magic-0.57/README 2015-04-17 16:59:24.000000000 +0200
+++ new/Variable-Magic-0.58/README 2015-07-21 17:42:56.000000000 +0200
@@ -2,7 +2,7 @@
Variable::Magic - Associate user-defined magic to variables from Perl.
VERSION
- Version 0.57
+ Version 0.58
SYNOPSIS
use Variable::Magic qw<wizard cast VMG_OP_INFO_NAME>;
@@ -265,10 +265,17 @@
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 *len* 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 *len* magic callback and
+ ignores all the others. Starting with Variable::Magic 0.58, a
+ reference returned from a non-*len* 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 cookbook.
Each callback can be specified as :
@@ -501,6 +508,45 @@
Of course, this example does nothing with the values that are added
after the "cast".
+ 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)
+
PERL MAGIC HISTORY
The places where magic is invoked have changed a bit through perl
history. Here is a little list of the most recent ones.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/lib/Variable/Magic.pm
new/Variable-Magic-0.58/lib/Variable/Magic.pm
--- old/Variable-Magic-0.57/lib/Variable/Magic.pm 2015-04-17
16:57:39.000000000 +0200
+++ new/Variable-Magic-0.58/lib/Variable/Magic.pm 2015-07-21
17:35:40.000000000 +0200
@@ -11,13 +11,13 @@
=head1 VERSION
-Version 0.57
+Version 0.58
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.57';
+ $VERSION = '0.58';
}
=head1 SYNOPSIS
@@ -309,8 +309,12 @@
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<len> 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<len> magic callback and ignores all the others.
+Starting with Variable::Magic 0.58, a reference returned from a non-I<len>
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<cookbook|/COOKBOOK>.
=back
@@ -577,6 +581,44 @@
Of course, this example does nothing with the values that are added after the
C<cast>.
+=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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/09-load-threads.t
new/Variable-Magic-0.58/t/09-load-threads.t
--- old/Variable-Magic-0.57/t/09-load-threads.t 2015-04-16 21:25:01.000000000
+0200
+++ new/Variable-Magic-0.58/t/09-load-threads.t 2015-07-21 17:24:34.000000000
+0200
@@ -29,9 +29,7 @@
my $could_not_create_thread = 'Could not create thread';
-use Test::Leaner (
- tests => 1 + (2 + 2 * 2) + 6 + (2 * 4 + 1) * 2 + (4 + 1) + (6 + 1) + 1
-);
+use Test::Leaner;
sub is_loaded {
my ($affirmative, $desc) = @_;
@@ -178,10 +176,19 @@
cond_broadcast $locks_down[$id];
}
- {
+ LOCK: {
lock $locks_up[$id];
- cond_wait $locks_up[$id] until $locks_up[$id] == $peers;
+ my $timeout = time() + 10;
+ until ($locks_up[$id] == $peers) {
+ if (cond_timedwait $locks_up[$id], $timeout) {
+ last LOCK;
+ } else {
+ return 0;
+ }
+ }
}
+
+ return 1;
}
sub sync_slave {
@@ -197,6 +204,8 @@
$locks_up[$id]++;
cond_signal $locks_up[$id];
}
+
+ return 1;
}
for my $first_thread_ends_first (0, 1) {
@@ -238,7 +247,7 @@
is_loaded 1, "$here, end";
- return;
+ return 1;
});
skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1;
@@ -263,7 +272,7 @@
is_loaded 1, "$here, end";
- return;
+ return 1;
});
sync_master($_) for 0 .. 5;
@@ -344,9 +353,6 @@
# Test clone outliving its parent
SKIP: {
- my $kid_tid;
- share($kid_tid);
-
my $kid_done;
share($kid_done);
@@ -354,11 +360,11 @@
my $here = 'outliving clone, parent thread';
is_loaded 0, "$here, beginning";
- my $no_kid;
-
do_load;
is_loaded 1, "$here, after loading";
+ my $kid_tid;
+
SKIP: {
my $kid = spawn(sub {
my $here = 'outliving clone, child thread';
@@ -366,52 +372,40 @@
is_loaded 1, "$here, beginning";
{
- lock $kid_tid;
- $kid_tid = threads->tid();
- cond_signal $kid_tid;
- }
-
- is_loaded 1, "$here, kid tid was communicated";
-
- {
lock $kid_done;
cond_wait $kid_done until $kid_done;
}
is_loaded 1, "$here, end";
- return;
+ return 1;
});
- unless (defined $kid) {
- $no_kid = 1;
- skip "$could_not_create_thread (outliving clone child)" => 3;
+ if (defined $kid) {
+ $kid_tid = $kid->tid;
+ } else {
+ $kid_tid = 0;
+ skip "$could_not_create_thread (outliving clone child)" => 2;
}
}
is_loaded 1, "$here, end";
- return $no_kid;
+ return $kid_tid;
});
- skip "$could_not_create_thread (outliving clone parent)" => (3 + 3)
+ skip "$could_not_create_thread (outliving clone parent)" => (3 + 2)
unless defined
$parent;
- my $no_kid = $parent->join;
+ my $kid_tid = $parent->join;
if (my $err = $parent->error) {
die $err;
}
- unless ($no_kid) {
- my $tid = do {
- lock $kid_tid;
- cond_wait $kid_tid until defined $kid_tid;
- $kid_tid;
- };
-
- my $kid = threads->object($tid);
+ if ($kid_tid) {
+ my $kid = threads->object($kid_tid);
if (defined $kid) {
- {
+ if ($kid->is_running) {
lock $kid_done;
$kid_done = 1;
cond_signal $kid_done;
@@ -426,3 +420,5 @@
do_load;
is_loaded 1, 'main body, loaded at end';
+
+done_testing();
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/18-opinfo.t
new/Variable-Magic-0.58/t/18-opinfo.t
--- old/Variable-Magic-0.57/t/18-opinfo.t 2014-10-21 00:10:58.000000000
+0200
+++ new/Variable-Magic-0.58/t/18-opinfo.t 2015-07-20 20:00:45.000000000
+0200
@@ -50,10 +50,13 @@
our $done;
+my $OP_INFO_NAME = VMG_OP_INFO_NAME;
+my $OP_INFO_OBJECT = VMG_OP_INFO_OBJECT;
+
for (@tests) {
my ($key, $var, $init, $test, $exp) = @$_;
- for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT) {
+ for my $op_info ($OP_INFO_NAME, $OP_INFO_OBJECT) {
my $wiz;
# We must test for the $op correctness inside the callback because, if we
@@ -64,9 +67,9 @@
return if $done;
my $op = $_[-1];
my $desc = "$key magic with op_info == $op_info";
- if ($op_info == VMG_OP_INFO_NAME) {
+ if ($op_info == $OP_INFO_NAME) {
is $op, $exp->[0], "$desc gets the right op info";
- } elsif ($op_info == VMG_OP_INFO_OBJECT) {
+ } elsif ($op_info == $OP_INFO_OBJECT) {
isa_ok $op, $exp->[1], $desc;
is $op->name, $exp->[0], "$desc gets the right op info";
} else {
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/40-threads.t
new/Variable-Magic-0.58/t/40-threads.t
--- old/Variable-Magic-0.57/t/40-threads.t 2015-04-14 18:58:11.000000000
+0200
+++ new/Variable-Magic-0.58/t/40-threads.t 2015-07-21 00:34:26.000000000
+0200
@@ -102,7 +102,8 @@
is $c, 1, "get in thread $tid after dispell doesn't trigger magic";
}
}
- return; # Ugly if not here
+
+ return 1;
}
for my $dispell (1, 0) {
@@ -111,11 +112,16 @@
$destroyed = 0;
}
+ my $completed = 0;
+
my @threads = map spawn(\&try, $dispell, $_), ('name') x 2, ('object') x 2;
- $_->join for @threads;
+ for my $thr (@threads) {
+ my $res = $thr->join;
+ $completed += $res if defined $res;
+ }
{
lock $destroyed;
- is $destroyed, (1 - $dispell) * 4, 'destructors';
+ is $destroyed, (1 - $dispell) * $completed, 'destructors';
}
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/41-clone.t
new/Variable-Magic-0.58/t/41-clone.t
--- old/Variable-Magic-0.57/t/41-clone.t 2015-04-14 18:39:50.000000000
+0200
+++ new/Variable-Magic-0.58/t/41-clone.t 2015-07-21 00:34:26.000000000
+0200
@@ -102,7 +102,7 @@
}
}
- return;
+ return 1;
}
my $wiz_name = spawn_wiz VMG_OP_INFO_NAME;
@@ -119,16 +119,21 @@
$destroyed = 0;
}
+ my $completed = 0;
+
my @threads = map spawn(\&try, $dispell, $wiz), 1 .. 2;
- $_->join for @threads;
+ for my $thr (@threads) {
+ my $res = $thr->join;
+ $completed += $res if defined $res;
+ }
{
lock $c;
- is $c, 2, "get triggered twice";
+ is $c, $completed, "get triggered twice";
}
{
lock $destroyed;
- is $destroyed, (1 - $dispell) * 2, 'destructors';
+ is $destroyed, (1 - $dispell) * $completed, 'destructors';
}
}
}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/50-return.t
new/Variable-Magic-0.58/t/50-return.t
--- old/Variable-Magic-0.57/t/50-return.t 1970-01-01 01:00:00.000000000
+0100
+++ new/Variable-Magic-0.58/t/50-return.t 2015-07-20 19:44:01.000000000
+0200
@@ -0,0 +1,195 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Variable::Magic qw<wizard cast dispell getdata>;
+
+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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/80-leaks.t
new/Variable-Magic-0.58/t/80-leaks.t
--- old/Variable-Magic-0.57/t/80-leaks.t 2014-10-20 23:23:19.000000000
+0200
+++ new/Variable-Magic-0.58/t/80-leaks.t 2015-07-20 18:44:26.000000000
+0200
@@ -3,9 +3,15 @@
use strict;
use warnings;
-use Test::More tests => 11;
+use Variable::Magic qw<wizard cast getdata dispell MGf_LOCAL VMG_UVAR>;
-use Variable::Magic qw<wizard cast getdata>;
+use Test::More;
+
+BEGIN {
+ my $tests = 11;
+ $tests += 4 * (4 + (MGf_LOCAL ? 1 : 0) + (VMG_UVAR ? 4 : 0));
+ plan tests => $tests;
+}
our $destroyed;
@@ -89,3 +95,69 @@
is $destroyed, 1;
}
+
+# Test destruction of returned values
+
+my @methods = qw<get set clear free>;
+push @methods, 'local' if MGf_LOCAL;
+push @methods, qw<fetch store exists delete> if VMG_UVAR;
+
+my %init = (
+ scalar_lexical => 'my $x = 1; cast $x, $w',
+ scalar_global => 'our $X; local $X = 1; cast $X, $w',
+ array => 'my @a = (1); cast @a, $w',
+ hash => 'my %h = (a => 1); cast %h, $w',
+);
+
+my %type;
+$type{$_} = 'scalar_lexical' for qw<get set free>;
+$type{$_} = 'scalar_global' for qw<local>;
+$type{$_} = 'array' for qw<clear>;
+$type{$_} = 'hash' for qw<fetch store exists delete>;
+
+sub void { }
+
+my %trigger = (
+ get => 'my $y = $x',
+ set => '$x = 2',
+ clear => '@a = ()',
+ free => 'void()',
+ local => 'local $X = 2',
+ fetch => 'my $v = $h{a}',
+ store => '$h{a} = 2',
+ exists => 'my $e = exists $h{a}',
+ delete => 'my $d = delete $h{a}',
+);
+
+for my $meth (@methods) {
+ local $destroyed = 0;
+
+ {
+ my $w = wizard $meth => sub { return D->new };
+
+ my $init = $init{$type{$meth}};
+ my $trigger = $trigger{$meth};
+ my $deinit = '';
+
+ if ($meth eq 'free') {
+ $init = "{\n$init";
+ $deinit = '}';
+ }
+
+ my $code = join ";\n", grep length, (
+ $init,
+ 'is $destroyed, 0, "return from $meth, before trigger"',
+ $trigger . ', is($destroyed, 0, "return from $meth, after trigger")',
+ $deinit,
+ 'is $destroyed, 1, "return from $meth, after trigger"',
+ );
+
+ {
+ local $@;
+ eval $code;
+ die $@ if $@;
+ }
+
+ is $destroyed, 1, "return from $meth, end";
+ }
+}
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/Variable-Magic-0.57/t/lib/VPIT/TestHelpers.pm
new/Variable-Magic-0.58/t/lib/VPIT/TestHelpers.pm
--- old/Variable-Magic-0.57/t/lib/VPIT/TestHelpers.pm 2015-04-14
19:05:51.000000000 +0200
+++ new/Variable-Magic-0.58/t/lib/VPIT/TestHelpers.pm 2015-07-21
00:33:52.000000000 +0200
@@ -600,6 +600,18 @@
=back
+=item *
+
+Notes :
+
+=over 8
+
+=item -
+
+C<< exit => 'threads_only' >> is passed to C<< threads->import >>.
+
+=back
+
=back
=cut
@@ -644,7 +656,9 @@
die "$test_module was loaded too soon" if defined $test_module;
}
- load_or_skip_all 'threads', $force ? '0' : '1.67', [ ];
+ load_or_skip_all 'threads', $force ? '0' : '1.67', [
+ exit => 'threads_only',
+ ];
load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ];
diag "Threads testing forced by \$ENV{$force_var}" if $force;
@@ -672,7 +686,18 @@
Import :
- use VPIT::TestHelpers 'usleep'
+ use VPIT::TestHelpers 'usleep' => [ @impls ];
+
+where :
+
+=over 8
+
+=item -
+
+C<@impls> is the list of desired implementations (which may be
C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be
checked.
+When the list is empty, it defaults to all of them.
+
+=back
=item *
@@ -695,20 +720,60 @@
=cut
sub init_usleep {
- my $usleep;
+ my (@impls) = @_;
- if (do { local $@; eval { require Time::HiRes; 1 } }) {
- defined and diag "Using usleep() from Time::HiRes $_"
+ my %impls = (
+ 'Time::HiRes' => sub {
+ if (do { local $@; eval { require Time::HiRes; 1 } }) {
+ defined and diag "Using usleep() from Time::HiRes $_"
for
$Time::HiRes::VERSION;
- $usleep = \&Time::HiRes::usleep;
- } else {
- diag 'Using fallback usleep()';
- $usleep = sub {
- my $s = int($_[0] / 1e6);
- sleep $s if $s;
- };
+ return \&Time::HiRes::usleep;
+ } else {
+ return undef;
+ }
+ },
+ 'select' => sub {
+ if ($Config::Config{d_select}) {
+ diag 'Using select()-based fallback usleep()';
+ return sub ($) {
+ my $s = $_[0];
+ my $r = 0;
+ while ($s > 0) {
+ my ($found, $t) = select(undef, undef, undef, $s / 1e6);
+ last unless defined $t;
+ $t = int($t * 1e6);
+ $s -= $t;
+ $r += $t;
+ }
+ return $r;
+ };
+ } else {
+ return undef;
+ }
+ },
+ 'sleep' => sub {
+ diag 'Using sleep()-based fallback usleep()';
+ return sub ($) {
+ my $ms = int $_[0];
+ my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1);
+ my $t = sleep $s;
+ return $t * 1e6;
+ };
+ },
+ );
+
+ @impls = qw<Time::HiRes select sleep> unless @impls;
+
+ my $usleep;
+ for my $impl (@impls) {
+ next unless defined $impl and $impls{$impl};
+ $usleep = $impls{$impl}->();
+ last if defined $usleep;
}
+ skip_all "Could not find a suitable usleep() implementation among: @impls"
+ unless
$usleep;
+
return usleep => $usleep;
}
