From mathias@cpan.org

This is a bug report for perl from mathias@​cpan.org,
generated with the help of perlbug 1.41 running under perl 5.30.0.

Here is a small instroductory example​:

$ perl -MSafe -e 'Safe->new()->reval("sub { die 1 }")->(); print "Should
not be here ($@​)\n"'

Which prints​: Should not be here ()

What we see is that code refs returned by Safe​::reval (which have been
wrapped
by wrap_code_ref) will hide exceptions when they run (and $@​ is not set
either).

Reading the code of wrap_code_ref I think that the intent was for the
exception
to be propagated. However this does not happen because the call to
_safe_call_sv
hides the exceptions (and there is no actual eval call so $@​ is not
set).

The fix is, inside wrap_code_ref, to wrap the call to $sub->(@​args)
inside an
eval when building the $sub_with_args variable.

However there are two possible ways to handle this​: either keep the
current code
which will trigger an exception, or remove the die call. I think that
the second
approach is safest as currently the errors are silently ignored so
starting to
die could break existing code (while setting $@​ is less disrupting
because the
caller has to explicitly check its value for something to happen).

The second approach (setting $@​ but not raising an exception), also has
the
advantage that wrapped code will behave as the code run through reval,
which is
more consistent with the documentation (the part that says that code
references
returned by reval are wrapped to be executed as in the compartiment).
Ideally
the wrapping should be propagated also to code reference returned
recursivelly
from code reference returned by reval.

The proposed patch applies these fixes​:
  - wrap the wrapped_code in an eval to catch exception;
  - do not raise these exceptions, let the user read them in $@​;
  - recursively wrap code returned by wrapped code;
  - bump the version to 2.41;
  - document this behavior.

Flags​:
  category=library
  severity=medium
  Type=Patch
  PatchStatus=HasPatch
  module=Safe

Site configuration information for perl 5.30.0​:

Configured by Mathias at Sat Sep 28 12​:50​:24 CEST 2019.

Summary of my perl5 (revision 5 version 30 subversion 0) configuration​:

  Platform​:
  osname=cygwin
  osvers=3.0.7(0.33853)
  archname=cygwin-thread-multi
  uname='cygwin_nt-10.0 mathias-2013 3.0.7(0.33853) 2019-04-30 18​:08
x86_64 cygwin '
  config_args='-de
-Dprefix=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0
-Aeval​:scriptdir=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0/bin'
  hint=recommended
  useposix=true
  d_sigaction=define
  useithreads=define
  usemultiplicity=define
  use64bitint=define
  use64bitall=define
  uselongdouble=undef
  usemymalloc=n
  default_inc_excludes_dot=define
  bincompat5005=undef
  Compiler​:
  cc='gcc'
  ccflags ='-DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -D_GNU_SOURCE
-fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong
-I/usr/local/include -D_FORTIFY_SOURCE=2'
  optimize='-O3'
  cppflags='-DPERL_USE_SAFE_PUTENV -U__STRICT_ANSI__ -D_GNU_SOURCE
-fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong
-I/usr/local/include'
  ccversion=''
  gccversion='7.4.0'
  gccosandvers=''
  intsize=4
  longsize=8
  ptrsize=8
  doublesize=8
  byteorder=12345678
  doublekind=3
  d_longlong=define
  longlongsize=8
  d_longdbl=define
  longdblsize=16
  longdblkind=3
  ivtype='long'
  ivsize=8
  nvtype='double'
  nvsize=8
  Off_t='off_t'
  lseeksize=8
  alignbytes=8
  prototype=define
  Linker and Libraries​:
  ld='g++'
  ldflags =' -Wl,--enable-auto-import -Wl,--export-all-symbols
-Wl,--enable-auto-image-base -fstack-protector-strong -L/usr/local/lib'
  libpth=/usr/local/lib /usr/lib /lib
  libs=-lpthread -ldl
  perllibs=-lpthread -ldl
  libc=/usr/lib/libc.a
  so=dll
  useshrplib=true
  libperl=cygperl5_30_0.dll
  gnulibc_version=''
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs
  dlext=dll
  d_dlsymun=undef
  ccdlflags=' '
  cccdlflags=' '
  lddlflags=' --shared -Wl,--enable-auto-import
-Wl,--export-all-symbols -Wl,--enable-auto-image-base -L/usr/local/lib
-fstack-protector-strong'

@​INC for perl 5.30.0​:
 
/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0/lib/site_perl/5.30.0/cygwin-thread-multi
 
/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0/lib/site_perl/5.30.0
 
/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0/lib/5.30.0/cygwin-thread-multi
 
/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/perl-5.30.0/lib/5.30.0

Environment for perl 5.30.0​:
  HOME=/cygdrive/d/Mathias/Cygwin
  LANG=fr_FR.UTF-8
  LANGUAGE (unset)
  LD_LIBRARY_PATH (unset)
  LOGDIR (unset)
 
PATH=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/bin​:/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/5.30/bin​:/cygdrive/d/Mathias/Cygwin/gitbin​:/usr/local/bin​:/usr/bin​:/cygdrive/c/Program
Files (x86)/Common
Files/Oracle/Java/javapath​:/cygdrive/c/Python27​:/cygdrive/c/Python27/Scripts​:/cygdrive/c/Windows/system32​:/cygdrive/c/Windows​:/cygdrive/c/Windows/System32/Wbem​:/cygdrive/c/Windows/System32/WindowsPowerShell/v1.0​:/cygdrive/c/Program
Files (x86)/NVIDIA
Corporation/PhysX/Common​:/cygdrive/c/WINDOWS/system32​:/cygdrive/c/WINDOWS​:/cygdrive/c/WINDOWS/System32/Wbem​:/cygdrive/c/WINDOWS/System32/WindowsPowerShell/v1.0​:/cygdrive/d/Programmes/Calibre2​:/cygdrive/c/Program
Files/Git/cmd​:/cygdrive/d/Programmes/LLVM/bin​:/cygdrive/d/Programmes/Heroku/bin​:/cygdrive/c/Program
Files
(x86)/git/cmd​:/cygdrive/d/Programmes/Skype/Phone​:/cygdrive/c/WINDOWS/System32/OpenSSH​:/cygdrive/c/Program
Files/NVIDIA
Corporation/NVIDIA
NvDLISR​:/cygdrive/d/Programmes/VisiCut​:/cygdrive/c/Program
Files/Pandoc​:/cygdrive/c/Users/Mathias/AppData/Local/Microsoft/WindowsApps​:/usr/lib/lapack
  PERL5LIB=
  PERLBREW_LIB=
 
PERLBREW_MANPATH=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/5.30/man
 
PERLBREW_PATH=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/bin​:/cygdrive/d/Mathias/Cygwin/perl5/perlbrew/perls/5.30/bin
  PERLBREW_PERL=5.30
  PERLBREW_ROOT=/cygdrive/d/Mathias/Cygwin/perl5/perlbrew
  PERLBREW_SKIP_INIT=1
  PERLBREW_VERSION=0.86
  PERL_BADLANG (unset)
  PERL_LOCAL_LIB_ROOT=
  SHELL=/bin/bash

Attachment(s)​:
  safe.patch

From mathias@cpan.org

--- Safe.pm	2019-09-28 13:02:38.305230800 +0200
+++ Safe2.pm	2019-09-28 13:13:01.406258300 +0200
@@ -3,7 +3,7 @@ package Safe;
 use 5.003_11;
 use Scalar::Util qw(reftype refaddr);
 
-$Safe::VERSION = "2.40";
+$Safe::VERSION = "2.41";
 
 # *** Don't declare any lexicals above this point ***
 #
@@ -423,23 +423,22 @@ sub wrap_code_ref {
 
     my $ret = sub {
         my @args = @_; # lexical to close over
-        my $sub_with_args = sub { $sub->(@args) };
+        my $sub_with_args = sub { eval { $sub->(@args) } };
 
         my @subret;
         my $error;
         do {
-            local $@;  # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR)
             my $sg = sub_generation();
-            @subret = (wantarray)
-                ?        Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
-                : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
-            $error = $@;
+            if (defined wantarray) {
+                @subret = (wantarray)
+                    ?        Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args)
+                    : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
+            } else {
+                Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args);
+            }
             _clean_stash($obj->{Root}.'::') if $sg != sub_generation();
         };
-        if ($error) { # rethrow exception
-            $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR
-            die $error;
-        }
+        $obj->wrap_code_refs_within(@subret);
         return (wantarray) ? @subret : $subret[0];
     };
 
@@ -750,7 +749,12 @@ package namespace adjusted and the opmas
 Note that the opmask doesn't affect the already compiled code, it only affects
 any I<further> compilation that the already compiled code may try to perform.
 
-This is particularly useful when applied to code references returned from reval().
+In addition, exception raised in the wrapped code will be trapped and $@ will be
+set instead. Any code reference returned by the wrapped code will itself be
+wrapped similarly.
+
+This is particularly useful when applied to code references returned from
+reval() (which is done automatically).
 
 (It also provides a kind of workaround for RT#60374: "Safe.pm sort {} bug with
 -Dusethreads". See L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=60374>

From @jkeenan

On Sat, 28 Sep 2019 11​:36​:36 GMT, mathias@​cpan.org wrote​:

This is a bug report for perl from mathias@​cpan.org,
generated with the help of perlbug 1.41 running under perl 5.30.0.

Here is a small instroductory example​:

$ perl -MSafe -e 'Safe->new()->reval("sub { die 1 }")->(); print
"Should
not be here ($@​)\n"'

Which prints​: Should not be here ()

What we see is that code refs returned by Safe​::reval (which have been
wrapped
by wrap_code_ref) will hide exceptions when they run (and $@​ is not
set
either).

Reading the code of wrap_code_ref I think that the intent was for the
exception
to be propagated. However this does not happen because the call to
_safe_call_sv
hides the exceptions (and there is no actual eval call so $@​ is not
set).

The fix is, inside wrap_code_ref, to wrap the call to $sub->(@​args)
inside an
eval when building the $sub_with_args variable.

However there are two possible ways to handle this​: either keep the
current code
which will trigger an exception, or remove the die call. I think that
the second
approach is safest as currently the errors are silently ignored so
starting to
die could break existing code (while setting $@​ is less disrupting
because the
caller has to explicitly check its value for something to happen).

The second approach (setting $@​ but not raising an exception), also
has
the
advantage that wrapped code will behave as the code run through reval,
which is
more consistent with the documentation (the part that says that code
references
returned by reval are wrapped to be executed as in the compartiment).
Ideally
the wrapping should be propagated also to code reference returned
recursivelly
from code reference returned by reval.

The proposed patch applies these fixes​:
- wrap the wrapped_code in an eval to catch exception;
- do not raise these exceptions, let the user read them in $@​;
- recursively wrap code returned by wrapped code;
- bump the version to 2.41;
- document this behavior.

The patch fails tests in Perl 5 blead. I created a local branch from perl 5 blead and applied your patch. I got the following test failures​:

#####
$ cd t;./perl harness -v ../dist/Safe/t/safesort.t ../dist/Safe/t/safewrap.t; cd -
../dist/Safe/t/safesort.t ..
1..10
ok 1
ok 2
ok 3 - reval should not fail
ok 4 - reval should return a CODE ref
ok 5
ok 6
not ok 7 - successful closure call should not alter $@​

# Failed test 'successful closure call should not alter $@​'
# at t/safesort.t line 47.
# got​: ''
# expected​: '42'
not ok 8 - should die # TODO Doesn't die in 5.13
# Failed (TODO) test 'should die'
# at t/safesort.t line 53.
not ok 9 - $@​ should be set correctly # TODO Doesn't die in 5.13
# Failed (TODO) test '$@​ should be set correctly'
# at t/safesort.t line 54.
# got​: ''
# expected​: 'died
# '
ok 10 # TODO Shouldn't warn
# Looks like you failed 1 test of 10.
Dubious, test returned 1 (wstat 256, 0x100)
Failed 1/10 subtests
  (1 TODO test unexpectedly succeeded)
../dist/Safe/t/safewrap.t ..
1..10
ok 1
ok 2
ok 3
not ok 4

# Failed test at t/safewrap.t line 27.
# ''
# doesn't match '(?^​:eval .* trapped by operation mask)'
ok 5 - original ref should be unaffected
ok 6
ok 7
ok 8
not ok 9

# Failed test at t/safewrap.t line 39.
# ''
# doesn't match '(?^​:eval .* trapped by operation mask)'
ok 10
# Looks like you failed 2 tests of 10.
Dubious, test returned 2 (wstat 512, 0x200)
Failed 2/10 subtests

Test Summary Report

../dist/Safe/t/safesort.t (Wstat​: 256 Tests​: 10 Failed​: 1)
  Failed test​: 7
  TODO passed​: 10
  Non-zero exit status​: 1
../dist/Safe/t/safewrap.t (Wstat​: 512 Tests​: 10 Failed​: 2)
  Failed tests​: 4, 9
  Non-zero exit status​: 2
Files=2, Tests=20, 0 wallclock secs ( 0.01 usr 0.00 sys + 0.10 cusr 0.01 csys = 0.12 CPU)
Result​: FAIL
/home/jkeenan/gitwork/perl
#####

Can you investigate further?

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

The RT System itself - Status changed from 'new' to 'open'