[rt.cpan.org #51574] Safe.pm sort {} bug accessing $a and $b with -Dusethreads

diff --git a/MANIFEST b/MANIFEST
index 04e197d..c238b8c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2755,6 +2755,7 @@ dist/Safe/t/safe2.t               See if Safe works
 dist/Safe/t/safe3.t            See if Safe works
 dist/Safe/t/safeload.t         Tests that some modules can be loaded by Safe
 dist/Safe/t/safeops.t          Tests that all ops can be trapped by Safe
+dist/Safe/t/safesort.t         Tests Safe with sort
 dist/Safe/t/safeuniversal.t    Tests Safe with functions from universal.c
 dist/SelfLoader/lib/SelfLoader.pm      Load functions only on demand
 dist/SelfLoader/t/01SelfLoader.t       See if SelfLoader works

diff --git a/dist/Safe/MANIFEST b/dist/Safe/MANIFEST
index 3f8b3f6..c424e6d 100644 (file)
--- a/dist/Safe/MANIFEST
+++ b/dist/Safe/MANIFEST
@@ -8,5 +8,6 @@ t/safe2.t
 t/safe3.t
 t/safeload.t
 t/safeops.t
+t/safesort.t
 t/safeuniversal.t
 META.yml                                 Module meta-data (added by MakeMaker)

diff --git a/dist/Safe/Safe.pm b/dist/Safe/Safe.pm
index 6926a4e..4313263 100644 (file)
--- a/dist/Safe/Safe.pm
+++ b/dist/Safe/Safe.pm
@@ -2,6 +2,9 @@ package Safe;
 
 use 5.003_11;
 use strict;
+use Scalar::Util qw(reftype);
+use Config qw(%Config);
+use constant is_usethreads => $Config{usethreads};
 
 $Safe::VERSION = "2.19";
 
@@ -288,8 +291,26 @@ sub reval {
     my ($obj, $expr, $strict) = @_;
     my $root = $obj->{Root};
 
-    my $evalsub = lexless_anon_sub($root,$strict, $expr);
-    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+    my $evalsub = lexless_anon_sub($root, $strict, $expr);
+    my @ret = (wantarray)
+        ?        Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub)
+        : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+
+    # RT#60374: Safe.pm sort {} bug with -Dusethreads
+    # If the Safe eval returns a code ref in a perl compiled with usethreads
+    # then wrap code ref with _safe_call_sv so that, when called, the
+    # execution will happen with the compartment fully 'in effect'.
+    # Needed to fix sort blocks that reference $a & $b and
+    # possibly other subtle issues.
+    if (is_usethreads()) {
+        for my $ret (@ret) { # edit (via alias) any CODE refs
+            next unless (reftype($ret)||'') eq 'CODE';
+            my $sub = $ret; # avoid closure problems
+            $ret = sub { Opcode::_safe_call_sv($root, $obj->{Mask}, $sub) };
+        }
+    }
+
+    return (wantarray) ? @ret : $ret[0];
 }
 
 sub rdo {

diff --git a/dist/Safe/t/safesort.t b/dist/Safe/t/safesort.t
new file mode 100644 (file)
index 0000000..383ad1a
--- /dev/null
+++ b/dist/Safe/t/safesort.t
@@ -0,0 +1,37 @@
+#!./perl -w
+$|=1;
+BEGIN {
+    if($ENV{PERL_CORE}) {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+    }
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+        print "1..0\n";
+        exit 0;
+    }
+}
+
+use Safe 1.00;
+use Test::More tests => 4;
+
+my $safe = Safe->new('PLPerl');
+$safe->permit_only(qw(:default sort));
+
+my $func = $safe->reval(<<'EOS');
+
+    # uses quotes in { "$a" <=> $b } to avoid the optimizer replacing the block
+    # with a hardwired comparison
+    { package Pkg; sub p_sort { return sort { "$a" <=> $b } qw(2 1 3); } }
+                   sub l_sort { return sort { "$a" <=> $b } qw(2 1 3); }
+
+    return sub { return join(",",l_sort()), join(",",Pkg::p_sort()) }
+
+EOS
+
+is $@, '', 'reval should not fail';
+is ref $func, 'CODE', 'reval should return a CODE ref';
+
+my ($l_sorted, $p_sorted) = $func->();
+is $l_sorted, "1,2,3";
+is $p_sorted, "1,2,3";