In perl.git, the branch smoke-me/jkeenan/133771-file-fine-taint has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/bdc8dbfdfe54fe52faac289384d4dada7a74b2f1?hp=a9c98c4ec34649055fad876effa0f675314644a8> discards a9c98c4ec34649055fad876effa0f675314644a8 (commit) discards e724baddb7406cc437d124a97e0413fab74b23f0 (commit) discards 1559574722c88bbbda15307fd568325280891cc2 (commit) discards a0762eb9364a1eac621c864e10d1617ec16cbf16 (commit) discards 67b7d10e63fbdfa64fa4d479035147d0cc573c2e (commit) discards 32d79802d3ec5d125baa9a7e1ced2082eec5d33c (commit) discards d9783b2762e83cf9ae9801550c74827df84e7cfb (commit) discards 26b896faacca73de0840c20d618f94ac86fd2d36 (commit) - Log ----------------------------------------------------------------- commit bdc8dbfdfe54fe52faac289384d4dada7a74b2f1 Author: James E Keenan <jkee...@cpan.org> Date: Mon Jul 8 13:50:41 2019 -0400 whitespace only commit 5fb7b632c885e2ab8a3c3e18274df1dd1dcd19f3 Author: James E Keenan <jkee...@cpan.org> Date: Mon Jul 8 08:28:19 2019 -0400 whitespace only commit 63ac49e376d7c89b5ac76bc032e624a584195cb4 Author: James E Keenan <jkee...@cpan.org> Date: Sun Jul 7 19:35:13 2019 -0400 whitespace only commit 3a8c4e10ed5bd033dd9fce739948995e7e838d36 Author: James E Keenan <jkee...@cpan.org> Date: Sun Jul 7 09:34:55 2019 -0400 Increment $VERSION to keep make test_porting happy commit 0627899d3ed910677a61a5614b6f97d193b2bde2 Author: James E Keenan <jkee...@cpan.org> Date: Sun Jul 7 08:36:37 2019 -0400 More debugging code Standardize indentation in relevant subroutine. commit 0cf356a09654f1fd170eafadc0750ca8d5f83d8d Author: James E Keenan <jkee...@cpan.org> Date: Sun Jul 7 01:44:38 2019 +0000 Comment out failing test temporarily commit 1c1b7bcbf68eb91d7df6dd2f8a68e90bc13cb2d1 Author: James E Keenan <jkee...@cpan.org> Date: Sat Jul 6 20:50:06 2019 -0400 Debugging code only. ----------------------------------------------------------------------- Summary of changes: autodoc.pl | 8 ++++++++ cop.h | 23 +++++++++++----------- ext/XS-APItest/Makefile.PL | 2 +- ext/XS-APItest/t/call.t | 26 ++++++++++++++++++++++++- perl.c | 25 +++++++++++++++--------- perl.h | 48 ++++++++++++++++++++++++++++++++++++++++++++++ pod/perldelta.pod | 12 ++++++++++++ 7 files changed, 122 insertions(+), 22 deletions(-) diff --git a/autodoc.pl b/autodoc.pl index 919da5e063..c72861accb 100644 --- a/autodoc.pl +++ b/autodoc.pl @@ -111,6 +111,14 @@ HDR_DOC: my $proto = $proto_in_file; $proto = "||$proto" unless $proto =~ /\|/; my($flags, $ret, $name, @args) = split /\s*\|\s*/, $proto; + $name or die <<EOS; +Bad apidoc at $file line $.: + $in +Expected: + =for apidoc flags|returntype|name|arg|arg|... + =for apidoc flags|returntype|name + =for apidoc name +EOS warn ("'$name' not \\w+ in '$proto_in_file' in $file") if $flags !~ /N/ && $name !~ / ^ [_[:alpha:]] \w* $ /x; my $docs = ""; diff --git a/cop.h b/cop.h index b9b61faa76..243f70094d 100644 --- a/cop.h +++ b/cop.h @@ -956,23 +956,24 @@ L<perlcall>. #define G_WANT 3 /* extra flags for Perl_call_* routines */ -#define G_DISCARD 4 /* Call FREETMPS. +#define G_DISCARD 0x4 /* Call FREETMPS. Don't change this without consulting the hash actions codes defined in hv.h */ -#define G_EVAL 8 /* Assume eval {} around subroutine call. */ -#define G_NOARGS 16 /* Don't construct a @_ array. */ -#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */ -#define G_NODEBUG 64 /* Disable debugging at toplevel. */ -#define G_METHOD 128 /* Calling method. */ -#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or +#define G_EVAL 0x8 /* Assume eval {} around subroutine call. */ +#define G_NOARGS 0x10 /* Don't construct a @_ array. */ +#define G_KEEPERR 0x20 /* Warn for errors, don't overwrite $@ */ +#define G_NODEBUG 0x40 /* Disable debugging at toplevel. */ +#define G_METHOD 0x80 /* Calling method. */ +#define G_FAKINGEVAL 0x100 /* Faking an eval context for call_sv or fold_constants. */ -#define G_UNDEF_FILL 512 /* Fill the stack with &PL_sv_undef +#define G_UNDEF_FILL 0x200 /* Fill the stack with &PL_sv_undef A special case for UNSHIFT in Perl_magic_methcall(). */ -#define G_WRITING_TO_STDERR 1024 /* Perl_write_to_stderr() is calling +#define G_WRITING_TO_STDERR 0x400 /* Perl_write_to_stderr() is calling Perl_magic_methcall(). */ -#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */ -#define G_METHOD_NAMED 4096 /* calling named method, eg without :: or ' */ +#define G_RE_REPARSING 0x800 /* compiling a run-time /(?{..})/ */ +#define G_METHOD_NAMED 0x1000 /* calling named method, eg without :: or ' */ +#define G_RETHROW 0x2000 /* eval_sv(): re-throw any error */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL index d79ba1150e..3fe5e397a8 100644 --- a/ext/XS-APItest/Makefile.PL +++ b/ext/XS-APItest/Makefile.PL @@ -23,7 +23,7 @@ WriteMakefile( my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE HV_FETCH_ISEXISTS HV_FETCH_LVALUE HV_FETCH_JUST_SV G_SCALAR G_ARRAY G_VOID G_DISCARD G_EVAL G_NOARGS - G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL + G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_RETHROW GV_NOADD_NOINIT IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t index 632a421d4f..e4228077cb 100644 --- a/ext/XS-APItest/t/call.t +++ b/ext/XS-APItest/t/call.t @@ -11,7 +11,7 @@ use strict; BEGIN { require '../../t/test.pl'; - plan(530); + plan(538); use_ok('XS::APItest') }; @@ -228,6 +228,30 @@ is(eval { eval_pv(q/die $obj/, 1) }, undef, ok(ref $@, "object thrown"); is($@, $obj, "check object rethrown"); +package False { + use overload + bool => sub { 0 }, + '""' => sub { "Foo" }; + sub new { bless {}, shift } +}; +my $false = False->new; +ok(!$false, "our false object is actually false"); +is(eval { eval_pv(q/die $false;/, 1); 1 }, undef, + "check false objects are rethrown"); +is(overload::StrVal($@), overload::StrVal($false), + "check we got the expected object"); + +is(eval { eval_sv(q/die $false/, G_RETHROW); 1 }, undef, + "check G_RETHROW for thrown object"); +is(overload::StrVal($@), overload::StrVal($false), + "check we got the expected object"); +is(eval { eval_sv(q/"unterminated/, G_RETHROW); 1 }, undef, + "check G_RETHROW for syntax error"); +like($@, qr/Can't find string terminator/, + "check error rethrown"); +ok(eq_array([ eval { eval_sv(q/"working code"/, G_RETHROW) } ], [ "working code", 1 ]), + "check for spurious rethrow"); + # #3719 - check that the eval call variants handle exceptions correctly, # and do the right thing with $@, both with and without G_KEEPERR set. diff --git a/perl.c b/perl.c index 2e80cfe940..e642f2e76d 100644 --- a/perl.c +++ b/perl.c @@ -3097,6 +3097,9 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) Tells Perl to C<eval> the string in the SV. It supports the same flags as C<call_sv>, with the obvious exception of C<G_EVAL>. See L<perlcall>. +The C<G_RETHROW> flag can be used if you only need eval_sv() to +execute code specified by a string, but not catch any errors. + =cut */ @@ -3178,6 +3181,11 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) goto redo_body; } fail: + if (flags & G_RETHROW) { + JMPENV_POP; + croak_sv(ERRSV); + } + PL_stack_sp = PL_stack_base + oldmark; if ((flags & G_WANT) == G_ARRAY) retval = 0; @@ -3214,8 +3222,14 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PERL_ARGS_ASSERT_EVAL_PV; - eval_sv(sv, G_SCALAR); - SvREFCNT_dec(sv); + if (croak_on_error) { + sv_2mortal(sv); + eval_sv(sv, G_SCALAR | G_RETHROW); + } + else { + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + } { dSP; @@ -3223,13 +3237,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PUTBACK; } - /* just check empty string or undef? */ - if (croak_on_error) { - SV * const errsv = ERRSV; - if(SvTRUE_NN(errsv)) - croak_sv(errsv); - } - return sv; } diff --git a/perl.h b/perl.h index f5f18ff4f7..37b2637ca1 100644 --- a/perl.h +++ b/perl.h @@ -1264,6 +1264,38 @@ EXTERN_C char *crypt(const char *, const char *); EXTERN_C char *crypt(const char *, const char *); #endif +/* +=head1 Errno + +=for apidoc m|void|SETERRNO|int errcode|int vmserrcode + +Set C<errno>, and on VMS set C<vaxc$errno>. + +=for apidoc mn|void|dSAVEDERRNO + +Declare variables needed to save C<errno> and any operating system +specific error number. + +=for apidoc mn|void|dSAVE_ERRNO + +Declare variables needed to save C<errno> and any operating system +specific error number, and save them for optional later restoration +by C<RESTORE_ERRNO>. + +=for apidoc mn|void|SAVE_ERRNO + +Save C<errno> and any operating system specific error number for +optional later restoration by C<RESTORE_ERRNO>. Requires +C<dSAVEDERRNO> or C<dSAVE_ERRNO> in scope. + +=for apidoc mn|void|RESTORE_ERRNO + +Restore C<errno> and any operating system specific error number that +was saved by C<dSAVE_ERRNO> or C<RESTORE_ERRNO>. + +=cut +*/ + #ifdef SETERRNO # undef SETERRNO /* SOCKS might have defined this */ #endif @@ -1335,6 +1367,22 @@ EXTERN_C char *crypt(const char *, const char *); # define RESTORE_ERRNO (errno = saved_errno) #endif +/* +=head1 Warning and Dieing + +=for apidoc Amn|SV *|ERRSV + +Returns the SV for C<$@>, creating it if needed. + +=for apidoc Am|void|CLEAR_ERRSV + +Clear the contents of C<$@>, setting it to the empty string. + +This replaces any read-only SV with a fresh SV and removes any magic. + +=cut +*/ + #define ERRSV GvSVn(PL_errgv) /* contains inlined gv_add_by_type */ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 45c930017e..1391930760 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -367,6 +367,13 @@ builds. Its normal use is to force perl to individually free every block of memory which it has allocated before exiting, which is useful when using automated leak detection tools such as valgrind. +=item * + +The API eval_sv() now accepts a C<G_RETHROW> flag. If this flag is +set and an exception is thrown while compiling or executing the +supplied code, it will be rethrown, and eval_sv() will not return. +[perl #134177] + =back =head1 Selected Bug Fixes @@ -386,6 +393,11 @@ to be parsed as part of the next token. This could lead to some silent changes in behaviour, so now incomplete hex or binary literals produce a fatal error. [perl #134125] +=item * + +eval_pv()'s I<croak_on_error> flag will now throw even if the +exception is a false overloaded value. [perl #134177] + =back =head1 Known Problems -- Perl5 Master Repository
