From: Vincent Pit <vince@profvince.com>
Date: Fri, 17 Jul 2015 18:54:47 +0000 (-0300)
Subject: Preserve previous compilation errors on fatal indirect constructs
X-Git-Tag: rt104312^0
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=4f7c4a9fe4fd2332dd2a748b17171f9d45129e4f;p=perl%2Fmodules%2Findirect.git

Preserve previous compilation errors on fatal indirect constructs

This fixes RT #104312.
---

diff --git a/MANIFEST b/MANIFEST
index 50876bd..5484282 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -20,6 +20,7 @@ t/23-bad-notaint.t
 t/30-scope.t
 t/31-hints.t
 t/32-global.t
+t/33-compilation-errors.t
 t/40-threads.t
 t/41-threads-teardown.t
 t/42-threads-global.t
diff --git a/Makefile.PL b/Makefile.PL
index d4c09f9..8dd474d 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -65,8 +65,13 @@ my %PREREQ_PM = (
 my %BUILD_REQUIRES =(
  'Config'              => 0,
  'ExtUtils::MakeMaker' => 0,
+ 'IO::Handle'          => 0,
+ 'IO::Select'          => 0,
+ 'IPC::Open3'          => 0,
  'POSIX'               => 0,
+ 'Socket'              => 0,
  'Test::More'          => 0,
+ 'lib'                 => 0,
  %PREREQ_PM,
 );
 
diff --git a/indirect.xs b/indirect.xs
index 3083abc..3d901d0 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -638,6 +638,68 @@ static void indirect_map_delete(pTHX_ const OP *o) {
   ptable_delete(MY_CXT.map, o);
 }
 
+/* --- Safe version of call_sv() ------------------------------------------- */
+
+static I32 indirect_call_sv(pTHX_ SV *sv, I32 flags) {
+#define indirect_call_sv(S, F) indirect_call_sv(aTHX_ (S), (F))
+ I32          ret, cxix;
+ PERL_CONTEXT saved_cx;
+ SV          *saved_errsv = NULL;
+
+ if (SvTRUE(ERRSV)) {
+  if (IN_PERL_COMPILETIME && PL_errors)
+   sv_catsv(PL_errors, ERRSV);
+  else
+   saved_errsv = newSVsv(ERRSV);
+  SvCUR_set(ERRSV, 0);
+ }
+
+ cxix     = (cxstack_ix < cxstack_max) ? (cxstack_ix + 1) : Perl_cxinc(aTHX);
+ /* The last popped context will be reused by call_sv(), but our callers may
+  * still need its previous value. Back it up so that it isn't clobbered. */
+ saved_cx = cxstack[cxix];
+
+ ret = call_sv(sv, flags | G_EVAL);
+
+ cxstack[cxix] = saved_cx;
+
+ if (SvTRUE(ERRSV)) {
+  /* Discard the old ERRSV, and reuse the variable to temporarily store the
+   * new one. */
+  if (saved_errsv)
+   sv_setsv(saved_errsv, ERRSV);
+  else
+   saved_errsv = newSVsv(ERRSV);
+  SvCUR_set(ERRSV, 0);
+  /* Immediately flush all errors. */
+  if (IN_PERL_COMPILETIME) {
+#if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
+   if (PL_parser)
+    ++PL_parser->error_count;
+#elif defined(PL_error_count)
+   ++PL_error_count;
+#else
+   ++PL_Ierror_count;
+#endif
+   if (PL_errors) {
+    sv_setsv(ERRSV, PL_errors);
+    SvCUR_set(PL_errors, 0);
+   }
+  }
+  sv_catsv(ERRSV, saved_errsv);
+  SvREFCNT_dec(saved_errsv);
+  croak(NULL);
+ } else if (saved_errsv) {
+  /* If IN_PERL_COMPILETIME && PL_errors, then the old ERRSV has already been
+   * added to PL_errors. Otherwise, just restore it to ERRSV, as if no eval
+   * block has ever been executed. */
+  sv_setsv(ERRSV, saved_errsv);
+  SvREFCNT_dec(saved_errsv);
+ }
+
+ return ret;
+}
+
 /* --- Check functions ----------------------------------------------------- */
 
 static int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *name_pos) {
@@ -995,7 +1057,7 @@ static OP *indirect_ck_entersub(pTHX_ OP *o) {
    mPUSHu(moi->line);
    PUTBACK;
 
-   call_sv(code, G_VOID);
+   indirect_call_sv(code, G_VOID);
 
    PUTBACK;
 
diff --git a/t/33-compilation-errors.t b/t/33-compilation-errors.t
new file mode 100644
index 0000000..be01768
--- /dev/null
+++ b/t/33-compilation-errors.t
@@ -0,0 +1,60 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use lib 't/lib';
+use VPIT::TestHelpers 'capture';
+
+BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
+
+sub compile_err_code {
+ my ($fatal) = @_;
+
+ if ($fatal) {
+  $fatal = 'no indirect q[fatal]; sub foo { \$bar }';
+ } else {
+  $fatal = 'no indirect;';
+ }
+
+ return "use strict; use warnings; $fatal; baz \$_; sub qux { \$ook }";
+}
+
+my $indirect_msg = qr/Indirect call of method "baz" on object "\$_"/;
+my $core_err1    = qr/Global symbol "\$bar"/;
+my $core_err2    = qr/Global symbol "\$ook"/;
+my $aborted      = qr/Execution of -e aborted due to compilation errors\./;
+my $line_end     = qr/[^\n]*\n/;
+my $compile_err_warn_exp  = qr/$indirect_msg$line_end$core_err2$line_end/o;
+my $compile_err_fatal_exp = qr/$core_err1$line_end$indirect_msg$line_end/o;
+
+SKIP: {
+ my ($stat, $out, $err) = capture_perl compile_err_code(0);
+ skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat;
+ like $err, qr/\A$compile_err_warn_exp$aborted$line_end\z/o,
+            'no indirect warn does not hide compilation errors outside of eval';
+}
+
+SKIP: {
+ my $code = compile_err_code(0);
+ my ($stat, $out, $err) = capture_perl "eval q[$code]; die \$@ if \$@";
+ skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat;
+ like $err, qr/\A$compile_err_warn_exp\z/o,
+             'no indirect warn does not hide compilation errors inside of eval';
+}
+
+SKIP: {
+ my ($stat, $out, $err) = capture_perl compile_err_code(1);
+ skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat;
+ like $err, qr/\A$compile_err_fatal_exp\z/o,
+           'no indirect fatal does not hide compilation errors outside of eval';
+}
+
+{
+ local $@;
+ eval compile_err_code(1);
+ like $@, qr/\A$compile_err_fatal_exp\z/o,
+            'no indirect fatal does not hide compilation errors inside of eval';
+}