diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | doio.c | 11 | ||||
| -rw-r--r-- | embed.fnc | 4 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 25 | ||||
| -rw-r--r-- | ext/XS-APItest/t/whichsig.t | 26 | ||||
| -rw-r--r-- | mg.c | 57 | ||||
| -rw-r--r-- | mg.h | 2 | ||||
| -rw-r--r-- | proto.h | 14 | ||||
| -rw-r--r-- | t/op/sigdispatch.t | 17 |
10 files changed, 137 insertions, 24 deletions
@@ -3870,6 +3870,7 @@ ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temp ext/XS-APItest/t/underscore_length.t Test find_rundefsv() ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed} ext/XS-APItest/t/utf8.t Tests for code in utf8.c +ext/XS-APItest/t/whichsig.t XS::APItest: tests for whichsig() and variants ext/XS-APItest/t/xs_special_subs_require.t for require too ext/XS-APItest/t/xs_special_subs.t Test that XS BEGIN/CHECK/INIT/END work ext/XS-APItest/t/xsub_h.t Tests for XSUB.h @@ -1567,6 +1567,7 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) register I32 tot = 0; const char *const what = PL_op_name[type]; const char *s; + STRLEN len; SV ** const oldmark = mark; PERL_ARGS_ASSERT_APPLY; @@ -1677,12 +1678,14 @@ nothing in the core. APPLY_TAINT_PROPER(); if (mark == sp) break; - s = SvPVx_nolen_const(*++mark); + s = SvPVx_const(*++mark, len); if (isALPHA(*s)) { - if (*s == 'S' && s[1] == 'I' && s[2] == 'G') + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { s += 3; - if ((val = whichsig(s)) < 0) - Perl_croak(aTHX_ "Unrecognized signal name \"%s\"",s); + len -= 3; + } + if ((val = whichsig_pvn(s, len)) < 0) + Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark)); } else val = SvIV(*mark); @@ -1454,7 +1454,9 @@ Afp |void |ck_warner_d |U32 err|NN const char* pat|... Ap |void |vwarner |U32 err|NN const char* pat|NULLOK va_list* args : FIXME p |void |watch |NN char** addr -Ap |I32 |whichsig |NN const char* sig +Ap |I32 |whichsig_sv |NN SV* sigsv +Ap |I32 |whichsig_pv |NN const char* sig +Ap |I32 |whichsig_pvn |NN const char* sig|STRLEN len : Used in pp_ctl.c p |void |write_to_stderr|NN SV* msv : Used in op.c @@ -695,7 +695,9 @@ #ifndef PERL_IMPLICIT_CONTEXT #define warner Perl_warner #endif -#define whichsig(a) Perl_whichsig(aTHX_ a) +#define whichsig_pv(a) Perl_whichsig_pv(aTHX_ a) +#define whichsig_pvn(a,b) Perl_whichsig_pvn(aTHX_ a,b) +#define whichsig_sv(a) Perl_whichsig_sv(aTHX_ a) #if !(defined(HAS_SIGACTION) && defined(SA_SIGINFO)) #define csighandler Perl_csighandler #endif diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index b9049e5299..0f09c3a95c 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -2003,6 +2003,31 @@ gv_autoload_type(stash, methname, type, method) XPUSHs( gv ? (SV*)gv : &PL_sv_undef); void +whichsig_type(namesv, type) + SV* namesv + int type + PREINIT: + STRLEN len; + const char * const name = SvPV_const(namesv, len); + I32 i; + PPCODE: + switch (type) { + case 0: + i = whichsig(name); + break; + case 1: + i = whichsig_sv(namesv); + break; + case 2: + i = whichsig_pv(name); + break; + case 3: + i = whichsig_pvn(name, len); + break; + } + XPUSHs(sv_2mortal(newSViv(i))); + +void eval_sv(sv, flags) SV* sv I32 flags diff --git a/ext/XS-APItest/t/whichsig.t b/ext/XS-APItest/t/whichsig.t new file mode 100644 index 0000000000..e87ba98495 --- /dev/null +++ b/ext/XS-APItest/t/whichsig.t @@ -0,0 +1,26 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 9; + +use_ok('XS::APItest'); + +my @types = map { 'whichsig' . $_ } '', qw( _sv _pv _pvn ); + +sub test { "Sanity check" } + +{ + for my $type ( 0..3 ) { + is XS::APItest::whichsig_type("KILL", $type), 9, "Sanity check, $types[$type] works"; + } +} + +is XS::APItest::whichsig_type("KILL\0whoops", 0), 9, "whichsig() is not nul-clean"; + +is XS::APItest::whichsig_type("KILL\0whoops", 1), -1, "whichsig_sv() is nul-clean"; + +is XS::APItest::whichsig_type("KILL\0whoops", 2), 9, "whichsig_pv() is not nul-clean"; + +is XS::APItest::whichsig_type("KILL\0whoops", 3), -1, "whichsig_pvn() is nul-clean"; @@ -1302,7 +1302,9 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETSIG; if (!i) { - mg->mg_private = i = whichsig(MgPV_nolen_const(mg)); + STRLEN siglen; + const char * sig = MgPV_const(mg, siglen); + mg->mg_private = i = whichsig_pvn(sig, siglen); } if (i > 0) { @@ -1493,9 +1495,9 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETSIG; if (*s == '_') { - if (strEQ(s,"__DIE__")) + if (memEQs(s, len, "__DIE__")) svp = &PL_diehook; - else if (strEQ(s,"__WARN__") + else if (memEQs(s, len, "__WARN__") && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { /* Merge the existing behaviours, which are as follows: magic_setsig, we always set svp to &PL_warnhook @@ -1503,8 +1505,11 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) For magic_clearsig, we don't change the warnings handler if it's set to the &PL_warnhook. */ svp = &PL_warnhook; - } else if (sv) - Perl_croak(aTHX_ "No such hook: %s", s); + } else if (sv) { + SV *tmp = sv_newmortal(); + Perl_croak(aTHX_ "No such hook: %s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } i = 0; if (svp && *svp) { if (*svp != PERL_WARNHOOK_FATAL) @@ -1515,12 +1520,15 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { i = (I16)mg->mg_private; if (!i) { - i = whichsig(s); /* ...no, a brick */ + i = whichsig_pvn(s, len); /* ...no, a brick */ mg->mg_private = (U16)i; } if (i <= 0) { - if (sv) - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) { + SV *tmp = sv_newmortal(); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } return 0; } #ifdef HAS_SIGPROCMASK @@ -1576,7 +1584,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } else { sv = NULL; } - if (sv && strEQ(s,"IGNORE")) { + if (sv && memEQs(s, len,"IGNORE")) { if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; @@ -1586,7 +1594,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) #endif } } - else if (!sv || strEQ(s,"DEFAULT") || !len) { + else if (!sv || memEQs(s, len,"DEFAULT") || !len) { if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; @@ -2981,22 +2989,41 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } I32 -Perl_whichsig(pTHX_ const char *sig) +Perl_whichsig_sv(pTHX_ SV *sigsv) +{ + const char *sigpv; + STRLEN siglen; + PERL_ARGS_ASSERT_WHICHSIG_SV; + PERL_UNUSED_CONTEXT; + sigpv = SvPV_const(sigsv, siglen); + return whichsig_pvn(sigpv, siglen); +} + +I32 +Perl_whichsig_pv(pTHX_ const char *sig) +{ + PERL_ARGS_ASSERT_WHICHSIG_PV; + PERL_UNUSED_CONTEXT; + return whichsig_pvn(sig, strlen(sig)); +} + +I32 +Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) { register char* const* sigv; - PERL_ARGS_ASSERT_WHICHSIG; + PERL_ARGS_ASSERT_WHICHSIG_PVN; PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) - if (strEQ(sig,*sigv)) + if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD - if (strEQ(sig,"CHLD")) + if (memEQs(sig, len, "CHLD")) return SIGCLD; #endif #ifdef SIGCHLD - if (strEQ(sig,"CLD")) + if (memEQs(sig, len, "CLD")) return SIGCHLD; #endif return -1; @@ -61,6 +61,8 @@ struct magic { #define SvTIED_obj(sv,mg) \ ((mg)->mg_obj ? (mg)->mg_obj : sv_2mortal(newRV(sv))) +#define whichsig(pv) whichsig_pv(pv) + /* * Local variables: * c-indentation-style: bsd @@ -4643,11 +4643,21 @@ PERL_CALLCONV void Perl_watch(pTHX_ char** addr) #define PERL_ARGS_ASSERT_WATCH \ assert(addr) -PERL_CALLCONV I32 Perl_whichsig(pTHX_ const char* sig) +PERL_CALLCONV I32 Perl_whichsig_pv(pTHX_ const char* sig) __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_WHICHSIG \ +#define PERL_ARGS_ASSERT_WHICHSIG_PV \ assert(sig) +PERL_CALLCONV I32 Perl_whichsig_pvn(pTHX_ const char* sig, STRLEN len) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_WHICHSIG_PVN \ + assert(sig) + +PERL_CALLCONV I32 Perl_whichsig_sv(pTHX_ SV* sigsv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_WHICHSIG_SV \ + assert(sigsv) + PERL_CALLCONV void Perl_write_to_stderr(pTHX_ SV* msv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_WRITE_TO_STDERR \ diff --git a/t/op/sigdispatch.t b/t/op/sigdispatch.t index 6b8c778203..3b8d6ec213 100644 --- a/t/op/sigdispatch.t +++ b/t/op/sigdispatch.t @@ -9,7 +9,7 @@ BEGIN { use strict; use Config; -plan tests => 23; +plan tests => 26; watchdog(15); @@ -122,3 +122,18 @@ SKIP: { alarm(0); is($@, "HANDLER CALLED\n", 'string eval'); } + +eval { $SIG{"__WARN__\0"} = sub { 1 } }; +like $@, qr/No such hook: __WARN__\\0 at/, q!Fetching %SIG hooks with an extra trailing nul is nul-clean!; + +eval { $SIG{"__DIE__\0whoops"} = sub { 1 } }; +like $@, qr/No such hook: __DIE__\\0whoops at/; + +{ + use warnings; + my $w; + local $SIG{__WARN__} = sub { $w = shift }; + + $SIG{"KILL\0"} = sub { 1 }; + like $w, qr/No such signal: SIGKILL\\0 at/, 'Arbitrary signal lookup through %SIG is clean'; +} |