*/
/*
-=head1 Magical Functions
+=head1 Magic
"Magic" is special data attached to SV structures in order to give them
"magical" properties. When any Perl code tries to read from, or assign to,
an SV marked as magical, it calls the 'get' or 'set' function associated
a MAGIC structure that contains a pointer to the object associated with the
tie.
+=for apidoc Ayh||MAGIC
+
=cut
*/
#include "EXTERN.h"
#define PERL_IN_MG_C
#include "perl.h"
+#include "feature.h"
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
# ifdef I_GRP
# include <sys/prctl.h>
#endif
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
-#else
-Signal_t Perl_csighandler(int sig);
-#endif
-
#ifdef __Lynx__
/* Missing protos on LynxOS */
void setruid(uid_t id);
const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
+ bool taint_only = TRUE; /* the only get method seen is taint */
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
/* taint's mg get is so dumb it doesn't need flag saving */
- if (!saved && mg->mg_type != PERL_MAGIC_taint) {
- save_magic(mgs_ix, sv);
- saved = TRUE;
- }
+ if (mg->mg_type != PERL_MAGIC_taint) {
+ taint_only = FALSE;
+ if (!saved) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+ }
vtbl->svt_get(aTHX_ sv, mg);
~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
- /* get-magic can reallocate the PV */
- magic_setutf8(sv, mg);
+ /* get-magic can reallocate the PV, unless there's only taint
+ * magic */
+ if (taint_only) {
+ MAGIC *mg2;
+ for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
+ if ( mg2->mg_type != PERL_MAGIC_taint
+ && !(mg2->mg_flags & MGf_GSKIP)
+ && mg2->mg_virtual
+ && mg2->mg_virtual->svt_get
+ ) {
+ taint_only = FALSE;
+ break;
+ }
+ }
+ }
+ if (!taint_only)
+ magic_setutf8(sv, mg);
}
mg = nextmg;
sv_magic(nsv,
(type == PERL_MAGIC_tied)
? SvTIED_obj(sv, mg)
- : (type == PERL_MAGIC_regdata && mg->mg_obj)
- ? sv
- : mg->mg_obj,
+ : mg->mg_obj,
toLOWER(type), key, klen);
count++;
}
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_free)
vtbl->svt_free(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
- if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
- Safefree(mg->mg_ptr);
- else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
- }
+
+ if (mg->mg_len > 0)
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_len == HEf_SVKEY)
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
+
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
}
/*
-=for apidoc Am|void|mg_free_type|SV *sv|int how
+=for apidoc mg_free_type
Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
MAGIC *mg, *prevmg, *moremg;
PERL_ARGS_ASSERT_MG_FREE_TYPE;
for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
- MAGIC *newhead;
moremg = mg->mg_moremagic;
if (mg->mg_type == how) {
+ MAGIC *newhead;
+ /* temporarily move to the head of the magic chain, in case
+ custom free code relies on this historical aspect of mg_free */
+ if (prevmg) {
+ prevmg->mg_moremagic = moremg;
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGIC_set(sv, mg);
+ }
+ newhead = mg->mg_moremagic;
+ mg_free_struct(sv, mg);
+ SvMAGIC_set(sv, newhead);
+ mg = prevmg;
+ }
+ }
+ mg_magical(sv);
+}
+
+/*
+=for apidoc mg_freeext
+
+Remove any magic of type C<how> using virtual table C<vtbl> from the
+SV C<sv>. See L</sv_magic>.
+
+C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
+
+=cut
+*/
+
+void
+Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
+{
+ MAGIC *mg, *prevmg, *moremg;
+ PERL_ARGS_ASSERT_MG_FREEEXT;
+ for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
+ MAGIC *newhead;
+ moremg = mg->mg_moremagic;
+ if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
/* temporarily move to the head of the magic chain, in case
custom free code relies on this historical aspect of mg_free */
if (prevmg) {
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
+ REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- if (mg->mg_obj) { /* @+ */
+ const SSize_t n = (SSize_t)mg->mg_obj;
+ if (n == '+') { /* @+ */
/* return the number possible */
return RX_NPARENS(rx);
- } else { /* @- */
+ } else { /* @- @^CAPTURE @{^CAPTURE} */
I32 paren = RX_LASTPAREN(rx);
/* return the last filled */
&& (RX_OFFS(rx)[paren].start == -1
|| RX_OFFS(rx)[paren].end == -1) )
paren--;
- return (U32)paren;
- }
+ if (n == '-') {
+ /* @- */
+ return (U32)paren;
+ } else {
+ /* @^CAPTURE @{^CAPTURE} */
+ return paren >= 0 ? (U32)(paren-1) : (U32)-1;
+ }
+ }
}
}
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
+ REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- const I32 paren = mg->mg_len;
+ const SSize_t n = (SSize_t)mg->mg_obj;
+ /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
+ const I32 paren = mg->mg_len
+ + (n == '\003' ? 1 : 0);
SSize_t s;
SSize_t t;
if (paren < 0)
(t = RX_OFFS(rx)[paren].end) != -1)
{
SSize_t i;
- if (mg->mg_obj) /* @+ */
+
+ if (n == '+') /* @+ */
i = t;
- else /* @- */
+ else if (n == '-') /* @- */
i = s;
+ else { /* @^CAPTURE @{^CAPTURE} */
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ return 0;
+ }
if (RX_MATCH_UTF8(rx)) {
const char * const b = RX_SUBBEG(rx);
}
}
}
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
return 0;
}
PERL_ARGS_ASSERT_EMULATE_COP_IO;
if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
- sv_setsv(sv, &PL_sv_undef);
+ sv_set_undef(sv);
else {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SvUTF8_off(sv);
if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
* avoid as many possible backward compatibility issues as possible, we
* don't turn on the flag unless we have to. So the flag stays off for
* an entirely invariant string. We assume that if the string looks
- * like UTF-8, it really is UTF-8: "text in any other encoding that
- * uses bytes with the high bit set is extremely unlikely to pass a
- * UTF-8 validity test"
+ * like UTF-8 in a single script, it really is UTF-8: "text in any
+ * other encoding that uses bytes with the high bit set is extremely
+ * unlikely to pass a UTF-8 validity test"
* (http://en.wikipedia.org/wiki/Charset_detection). There is a
* potential that we will get it wrong however, especially on short
- * error message text. (If it turns out to be necessary, we could also
- * keep track if the current LC_MESSAGES locale is UTF-8) */
- if (! IN_BYTES /* respect 'use bytes' */
- && ! is_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
- {
+ * error message text, so do an additional check. */
+ if ( ! IN_BYTES /* respect 'use bytes' */
+ && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
+
+#ifdef USE_LOCALE_MESSAGES
+
+ && _is_cur_LC_category_utf8(LC_MESSAGES)
+
+#else /* If can't check directly, at least can see if script is consistent,
+ under UTF-8, which gives us an extra measure of confidence. */
+
+ && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
+ TRUE) /* Means assume UTF-8 */
+#endif
+
+ ) {
SvUTF8_on(sv);
}
}
}
+/*
+=for apidoc_section $errno
+=for apidoc sv_string_from_errnum
+
+Generates the message string describing an OS error and returns it as
+an SV. C<errnum> must be a value that C<errno> could take, identifying
+the type of error.
+
+If C<tgtsv> is non-null then the string will be written into that SV
+(overwriting existing content) and it will be returned. If C<tgtsv>
+is a null pointer then the string will be written into a new mortal SV
+which will be returned.
+
+The message will be taken from whatever locale would be used by C<$!>,
+and will be encoded in the SV in whatever manner would be used by C<$!>.
+The details of this process are subject to future change. Currently,
+the message is taken from the C locale by default (usually producing an
+English message), and from the currently selected locale when in the scope
+of the C<use locale> pragma. A heuristic attempt is made to decode the
+message from the locale's character encoding, but it will only be decoded
+as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
+locale, usually in an ISO-8859-1 locale, and never in any other locale.
+
+The SV is always returned containing an actual string, and with no other
+OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
+(meaning success), and if no useful message is available then a useless
+string (currently empty) is returned.
+
+=cut
+*/
+
+SV *
+Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
+{
+ char const *errstr;
+ if(!tgtsv)
+ tgtsv = sv_newmortal();
+ errstr = my_strerror(errnum);
+ if(errstr) {
+ sv_setpv(tgtsv, errstr);
+ fixup_errno_string(tgtsv);
+ } else {
+ SvPVCLEAR(tgtsv);
+ }
+ return tgtsv;
+}
+
#ifdef VMS
#include <descrip.h>
#include <starlet.h>
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
do_numbuf_fetch:
CALLREG_NUMBUF_FETCH(rx,paren,sv);
- } else {
- sv_setsv(sv,&PL_sv_undef);
}
+ else
+ goto set_undef;
return 0;
}
switch (*mg->mg_ptr) {
case '\001': /* ^A */
if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
- else sv_setsv(sv, &PL_sv_undef);
+ else
+ sv_set_undef(sv);
if (SvTAINTED(PL_bodytarget))
SvTAINTED_on(sv);
break;
case '\005': /* ^E */
if (nextchar != '\0') {
if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
break;
}
if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
else
- sv_setpvs(sv,"");
+ SvPVCLEAR(sv);
}
#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
fixup_errno_string(sv);
}
else
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
SetLastError(dwErr);
}
# else
break;
#endif /* End of platforms with special handling for $^E; others just fall
through to $! */
+ /* FALLTHROUGH */
case '!':
{
else
#endif
if (! errno) {
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
}
else {
-
- /* Strerror can return NULL on some platforms, which will
- * result in 'sv' not being considered SvOK. The SvNOK_on()
+ sv_string_from_errnum(errno, sv);
+ /* If no useful string is available, don't
+ * claim to have a string part. The SvNOK_on()
* below will cause just the number part to be valid */
- sv_setpv(sv, my_strerror(errno));
- if (SvOK(sv)) {
- fixup_errno_string(sv);
- }
+ if (!SvCUR(sv))
+ SvPOK_off(sv);
}
RESTORE_ERRNO;
}
break;
case '\006': /* ^F */
- sv_setiv(sv, (IV)PL_maxsysfd);
+ if (nextchar == '\0') {
+ sv_setiv(sv, (IV)PL_maxsysfd);
+ }
break;
case '\007': /* ^GLOBAL_PHASE */
if (strEQ(remaining, "LOBAL_PHASE")) {
}
break;
case '\010': /* ^H */
- sv_setiv(sv, (IV)PL_hints);
+ sv_setuv(sv, PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\014': /* ^LAST_FH */
if (strEQ(remaining, "AST_FH")) {
- if (PL_last_in_gv) {
+ if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
assert(isGV_with_GP(PL_last_in_gv));
SV_CHECK_THINKFIRST_COW_DROP(sv);
prepare_SV_for_RV(sv);
SvROK_on(sv);
sv_rvweaken(sv);
}
- else sv_setsv_nomg(sv, NULL);
+ else
+ sv_set_undef(sv);
}
break;
case '\017': /* ^O & ^OPEN */
sv_setiv(sv, (IV)PL_perldb);
break;
case '\023': /* ^S */
- {
+ if (nextchar == '\0') {
if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
else
sv_setiv(sv, 0);
}
+ else if (strEQ(remaining, "AFE_LOCALES")) {
+
+#if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
+
+ sv_setuv(sv, (UV) 1);
+
+#else
+ sv_setuv(sv, (UV) 0);
+
+#endif
+
+ }
break;
case '\024': /* ^T */
if (nextchar == '\0') {
break;
case '\027': /* ^W & $^WARNING_BITS */
if (nextchar == '\0')
- sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
+ sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
else if (strEQ(remaining, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
else if (PL_compiling.cop_warnings == pWARN_STD) {
- sv_setsv(sv, &PL_sv_undef);
- break;
+ goto set_undef;
}
else if (PL_compiling.cop_warnings == pWARN_ALL) {
- /* Get the bit mask for $warnings::Bits{all}, because
- * it could have been extended by warnings::register */
- HV * const bits = get_hv("warnings::Bits", 0);
- SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
- if (bits_all)
- sv_copypv(sv, *bits_all);
- else
- sv_setpvn(sv, WARN_ALLstring, WARNsize);
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
if (paren)
goto do_numbuf_fetch;
}
- sv_setsv(sv,&PL_sv_undef);
- break;
+ goto set_undef;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = RX_LASTCLOSEPAREN(rx);
if (paren)
goto do_numbuf_fetch;
}
- sv_setsv(sv,&PL_sv_undef);
- break;
+ goto set_undef;
case '.':
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
else
- sv_setsv(sv, &PL_sv_undef);
+ goto set_undef;
break;
case '$': /* $$ */
{
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i;
I32 num_groups = getgroups(0, gary);
if (num_groups > 0) {
+ I32 i;
Newx(gary, num_groups, Groups_t);
num_groups = getgroups(num_groups, gary);
for (i = 0; i < num_groups; i++)
- Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+ Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
Safefree(gary);
}
}
break;
}
return 0;
+
+ set_undef:
+ sv_set_undef(sv);
+ return 0;
}
int
if (TAINTING_get) {
MgTAINTEDDIR_off(mg);
#ifdef VMS
- if (s && klen == 8 && strEQ(key, "DCL$PATH")) {
+ if (s && memEQs(key, klen, "DCL$PATH")) {
char pathbuf[256], eltbuf[256], *cp, *elt;
int i = 0, j = 0;
} while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
}
#endif /* VMS */
- if (s && klen == 4 && strEQ(key,"PATH")) {
+ if (s && memEQs(key, klen, "PATH")) {
const char * const strend = s + len;
+ /* set MGf_TAINTEDDIR if any component of the new path is
+ * relative or world-writeable */
while (s < strend) {
char tmpbuf[256];
Stat_t st;
I32 i;
-#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
- const char path_sep = '|';
+#ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
+ const char path_sep = PL_perllib_sep;
#else
const char path_sep = ':';
#endif
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
s, strend, path_sep, &i);
s++;
if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
-#ifdef VMS
- || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
+#ifdef __VMS
+ /* no colon thus no device name -- assume relative path */
+ || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
+ /* Using Unix separator, e.g. under bash, so act line Unix */
+ || (PL_perllib_sep == ':' && *tmpbuf != '/')
#else
|| *tmpbuf != '/' /* no starting slash -- assume relative path */
#endif
if(sigstate == (Sighandler_t) SIG_IGN)
sv_setpvs(sv,"IGNORE");
else
- sv_setsv(sv,&PL_sv_undef);
+ sv_set_undef(sv);
PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
SvTEMP_off(sv);
}
return sv_unmagic(sv, mg->mg_type);
}
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
Signal_t
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
+Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
+{
+ Perl_csighandler3(sig, sip, uap);
+}
#else
+Signal_t
Perl_csighandler(int sig)
+{
+ Perl_csighandler3(sig, NULL, NULL);
+}
#endif
+
+Signal_t
+Perl_csighandler1(int sig)
+{
+ Perl_csighandler3(sig, NULL, NULL);
+}
+
+/* Handler intended to directly handle signal calls from the kernel.
+ * (Depending on configuration, the kernel may actually call one of the
+ * wrappers csighandler() or csighandler1() instead.)
+ * It either queues up the signal or dispatches it immediately depending
+ * on whether safe signals are enabled and whether the signal is capable
+ * of being deferred (e.g. SEGV isn't).
+ */
+
+Signal_t
+Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
#else
dTHX;
#endif
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
#if defined(__cplusplus) && defined(__GNUC__)
/* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
* parameters would be warned about. */
PERL_UNUSED_ARG(uap);
#endif
#endif
+
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
(PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() or being destructed etc. */
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- (*PL_sighandlerp)(sig, NULL, NULL);
+ {
+ if (PL_sighandlerp == Perl_sighandler)
+ /* default handler, so can call perly_sighandler() directly
+ * rather than via Perl_sighandler, passing the extra
+ * 'safe = false' arg
+ */
+ Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
+ else
+#ifdef PERL_USE_3ARG_SIGHANDLER
+ (*PL_sighandlerp)(sig, NULL, NULL);
#else
- (*PL_sighandlerp)(sig);
+ (*PL_sighandlerp)(sig);
#endif
+ }
else {
if (!PL_psig_pend) return;
/* Set a flag to say this signal is pending, that is awaiting delivery after
}
#endif
PL_psig_pend[sig] = 0;
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- (*PL_sighandlerp)(sig, NULL, NULL);
+ if (PL_sighandlerp == Perl_sighandler)
+ /* default handler, so can call perly_sighandler() directly
+ * rather than via Perl_sighandler, passing the extra
+ * 'safe = true' arg
+ */
+ Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
+ else
+#ifdef PERL_USE_3ARG_SIGHANDLER
+ (*PL_sighandlerp)(sig, NULL, NULL);
#else
- (*PL_sighandlerp)(sig);
+ (*PL_sighandlerp)(sig);
#endif
+
#ifdef HAS_SIGPROCMASK
if (!was_blocked)
LEAVE;
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 i;
SV** svp = NULL;
/* Need to be careful with SvREFCNT_dec(), because that can have side
Ideally we'd find some way of making SVs at (C) compile time, or
at least, doing most of the work. */
if (!PL_psig_name[i]) {
- PL_psig_name[i] = newSVpvn(s, len);
+ const char* name = PL_sig_name[i];
+ PL_psig_name[i] = newSVpvn(name, strlen(name));
SvREADONLY_on(PL_psig_name[i]);
}
} else {
* access to a known hint bit in a known OP, we can't
* tell whether HINT_STRICT_REFS is in force or not.
*/
- if (!strchr(s,':') && !strchr(s,'\''))
+ if (!memchr(s, ':', len) && !memchr(s, '\'', len))
Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
SV_GMAGIC);
if (i)
}
/*
+=for apidoc_section $magic
=for apidoc magic_methcall
Invoke a magic method (like FETCH).
va_start(args, argc);
do {
- SV *const sv = va_arg(args, SV *);
- PUSHs(sv);
+ SV *const this_sv = va_arg(args, SV *);
+ PUSHs(this_sv);
} while (--argc);
va_end(args);
/* The magic ptr/len for the debugger's hash should always be an SV. */
if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
- Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'",
+ Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
(IV)mg->mg_len, mg->mg_ptr);
}
if (obj) {
sv_setiv(sv, AvFILL(obj));
} else {
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
}
return 0;
}
PERL_UNUSED_CONTEXT;
/* Reset the iterator when the array is cleared */
-#if IVSIZE == I32SIZE
- *((IV *) &(mg->mg_len)) = 0;
-#else
- if (mg->mg_ptr)
- *((IV *) mg->mg_ptr) = 0;
-#endif
+ if (sizeof(IV) == sizeof(SSize_t)) {
+ *((IV *) &(mg->mg_len)) = 0;
+ } else {
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+ }
return 0;
}
sv_setuv(sv, i);
return 0;
}
- sv_setsv(sv,NULL);
+ sv_set_undef(sv);
return 0;
}
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
- STRLEN ulen = 0;
MAGIC* found;
const char *s;
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_or_pv_len_utf8(lsv, s, len);
+ const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
const char * const tmps = SvPV_const(lsv,len);
STRLEN offs = LvTARGOFF(sv);
STRLEN rem = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool negrem = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
)) {
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
- sv_setsv_nomg(sv, &PL_sv_undef);
+ sv_set_undef(sv);
return 0;
}
SV * const lsv = LvTARG(sv);
STRLEN lvoff = LvTARGOFF(sv);
STRLEN lvlen = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool neglen = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+ char errflags = LvFLAGS(sv);
PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+ /* non-zero errflags implies deferred out-of-range condition */
+ assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
+ sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
}
int
+Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
+ PERL_UNUSED_ARG(mg);
+ sv_unmagic(sv, PERL_MAGIC_nonelem);
+ return 0;
+}
+
+int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
return 0;
}
+
+int
+Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
+ PERL_UNUSED_ARG(sv);
+
+ /* glob magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ return 0;
+}
+
+
int
Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
- if (type == PERL_MAGIC_qr) {
- } else if (type == PERL_MAGIC_bm) {
- SvTAIL_off(sv);
- SvVALID_off(sv);
- } else {
- assert(type == PERL_MAGIC_fm);
- }
+ assert( type == PERL_MAGIC_fm
+ || type == PERL_MAGIC_qr
+ || type == PERL_MAGIC_bm);
return sv_unmagic(sv, type);
}
}
return 0;
}
+
+int
+Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
+ PERL_UNUSED_ARG(sv);
+
+ /* Collate magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ if (mg->mg_len >= 0) {
+ assert(mg->mg_type == PERL_MAGIC_collxfrm);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ }
+
+ return 0;
+}
#endif /* USE_LOCALE_COLLATE */
/* Just clear the UTF-8 cache data. */
}
int
+Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
+ PERL_UNUSED_ARG(sv);
+
+ /* utf8 magic uses mg_len as a string length rather than a buffer
+ * length, so we need to free even with mg_len == 0: hence we can't
+ * rely on standard magic free handling */
+ assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ return 0;
+}
+
+
+int
Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
{
const char *bad = NULL;
PERL_TSA_REQUIRES(PL_dollarzero_mutex)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
const char *s;
STRLEN len;
* the setproctitle() routine to manipulate that. */
if (PL_origalen != 1) {
s = SvPV_const(sv, len);
-# if __FreeBSD_version > 410001
+# if __FreeBSD_version > 410001 || defined(__DragonFly__)
/* The leading "-" removes the "perl: " prefix,
* but not the "(perl) suffix from the ps(1)
* output, because that's what ps(1) shows if the
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
I32 paren;
const REGEXP * rx;
FmLINES(PL_bodytarget) = 0;
if (SvPOK(PL_bodytarget)) {
char *s = SvPVX(PL_bodytarget);
- while ( ((s = strchr(s, '\n'))) ) {
+ char *e = SvEND(PL_bodytarget);
+ while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
FmLINES(PL_bodytarget)++;
s++;
}
if (*(mg->mg_ptr+1) == '\0') {
#ifdef VMS
set_vaxc_errno(SvIV(sv));
-#else
-# ifdef WIN32
+#elif defined(WIN32)
SetLastError( SvIV(sv) );
-# else
-# ifdef OS2
+#elif defined(OS2)
os2_setsyserrno(SvIV(sv));
-# else
+#else
/* will anyone ever use this? */
SETERRNO(SvIV(sv), 4);
-# endif
-# endif
#endif
}
- else {
- if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
- if (PL_localizing != 2) {
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "${^ENCODING} is no longer supported");
- }
- }
+ else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
+ Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
break;
case '\006': /* ^F */
- PL_maxsysfd = SvIV(sv);
+ if (mg->mg_ptr[1] == '\0') {
+ PL_maxsysfd = SvIV(sv);
+ }
break;
case '\010': /* ^H */
- PL_hints = SvIV(sv);
+ {
+ U32 save_hints = PL_hints;
+ PL_hints = SvUV(sv);
+
+ /* If wasn't UTF-8, and now is, notify the parser */
+ if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
+ notify_parser_that_changed_to_utf8();
+ }
+ }
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
Safefree(PL_inplace);
else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
if (!SvPOK(sv)) {
- PL_compiling.cop_warnings = pWARN_STD;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
break;
}
{
STRLEN len, i;
- int accumulate = 0 ;
- int any_fatals = 0 ;
- const char * const ptr = SvPV_const(sv, len) ;
+ int not_none = 0, not_all = 0;
+ const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
for (i = 0 ; i < len ; ++i) {
- accumulate |= ptr[i] ;
- any_fatals |= (ptr[i] & 0xAA) ;
+ not_none |= ptr[i];
+ not_all |= ptr[i] ^ 0x55;
}
- if (!accumulate) {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE;
- }
- /* Yuck. I can't see how to abstract this: */
- else if (isWARN_on(
- ((STRLEN *)SvPV_nolen_const(sv)) - 1,
- WARN_ALL)
- && !any_fatals)
- {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_ALL;
- PL_dowarn |= G_WARN_ONCE ;
- }
- else {
- STRLEN len;
- const char *const p = SvPV_const(sv, len);
-
- PL_compiling.cop_warnings
- = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+ if (!not_none) {
+ free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
+ } else if (len >= WARNsize && !not_all) {
+ free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
+ PL_dowarn |= G_WARN_ONCE ;
+ }
+ else {
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
p, len);
- if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
+ if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
- }
+ }
}
}
}
#ifdef WIN32
else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
- w32_sloppystat = (bool)sv_true(sv);
+ w32_sloppystat = SvTRUE(sv);
}
#endif
break;
break;
case '/':
{
- SV *tmpsv= sv;
if (SvROK(sv)) {
- SV *referent= SvRV(sv);
- const char *reftype= sv_reftype(referent, 0);
- /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
- * is to copy pretty much the entire sv_reftype() into this routine, or to do
- * a full string comparison on the return of sv_reftype() both of which
- * make me feel worse! NOTE, do not modify this comment without reviewing the
- * corresponding comment in sv_reftype(). - Yves */
+ SV *referent = SvRV(sv);
+ const char *reftype = sv_reftype(referent, 0);
+ /* XXX: dodgy type check: This leaves me feeling dirty, but
+ * the alternative is to copy pretty much the entire
+ * sv_reftype() into this routine, or to do a full string
+ * comparison on the return of sv_reftype() both of which
+ * make me feel worse! NOTE, do not modify this comment
+ * without reviewing the corresponding comment in
+ * sv_reftype(). - Yves */
if (reftype[0] == 'S' || reftype[0] == 'L') {
- IV val= SvIV(referent);
+ IV val = SvIV(referent);
if (val <= 0) {
- tmpsv= &PL_sv_undef;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
- SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
- );
+ sv_setsv(sv, PL_rs);
+ Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
+ val < 0 ? "a negative integer" : "zero");
}
} else {
sv_setsv(sv, PL_rs);
- /* diag_listed_as: Setting $/ to %s reference is forbidden */
+ /* diag_listed_as: Setting $/ to %s reference is forbidden */
Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
*reftype == 'A' ? "n" : "", reftype);
}
}
SvREFCNT_dec(PL_rs);
- PL_rs = newSVsv(tmpsv);
+ PL_rs = newSVsv(sv);
}
break;
case '\\':
#else
# define PERL_VMS_BANG 0
#endif
-#if defined(WIN32) && ! defined(UNDER_CE)
+#if defined(WIN32)
SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
(SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
#else
}
#ifdef HAS_SETRUID
PERL_UNUSED_RESULT(setruid(new_uid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
-#ifdef PERL_DARWIN
+# ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
PERL_UNUSED_RESULT(PerlProc_setuid(0));
-#endif
+# endif
PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '>':
}
#ifdef HAS_SETEUID
PERL_UNUSED_RESULT(seteuid(new_euid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '(':
}
#ifdef HAS_SETRGID
PERL_UNUSED_RESULT(setrgid(new_gid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ')':
{
const char *p = SvPV_const(sv, len);
Groups_t *gary = NULL;
- const char* endptr;
+ const char* p_end = p + len;
+ const char* endptr = p_end;
UV uv;
#ifdef _SC_NGROUPS_MAX
int maxgrp = sysconf(_SC_NGROUPS_MAX);
if (endptr == NULL)
break;
p = endptr;
+ endptr = p_end;
while (isSPACE(*p))
++p;
if (!*p)
}
#ifdef HAS_SETEGID
PERL_UNUSED_RESULT(setegid(new_egid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ':':
return 0;
}
+/*
+=for apidoc_section $signals
+=for apidoc whichsig
+=for apidoc_item whichsig_pv
+=for apidoc_item whichsig_pvn
+=for apidoc_item whichsig_sv
+
+These all convert a signal name into its corresponding signal number;
+returning -1 if no corresponding number was found.
+
+They differ only in the source of the signal name:
+
+C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
+C<sig>.
+
+C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
+
+C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
+C<len> bytes.
+
+C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
+
+=cut
+*/
+
I32
Perl_whichsig_sv(pTHX_ SV *sigsv)
{
return -1;
}
+
+/* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
+ * these three function are intended to be called by the OS as 'C' level
+ * signal handler functions in the case where unsafe signals are being
+ * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
+ * perl-level sighandler, rather than deferring.
+ * In fact, the core itself will normally use Perl_csighandler as the
+ * OS-level handler; that function will then decide whether to queue the
+ * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
+ * functions are more useful for e.g. POSIX.xs when it wants explicit
+ * control of what's happening.
+ */
+
+
+#ifdef PERL_USE_3ARG_SIGHANDLER
+
Signal_t
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, siginfo_t *sip, void *uap)
+Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
+{
+ Perl_perly_sighandler(sig, sip, uap, 0);
+}
+
#else
+
+Signal_t
Perl_sighandler(int sig)
+{
+ Perl_perly_sighandler(sig, NULL, NULL, 0);
+}
+
#endif
+
+Signal_t
+Perl_sighandler1(int sig)
+{
+ Perl_perly_sighandler(sig, NULL, NULL, 0);
+}
+
+Signal_t
+Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
+{
+ Perl_perly_sighandler(sig, sip, uap, 0);
+}
+
+
+/* Invoke the perl-level signal handler. This function is called either
+ * directly from one of the C-level signals handlers (Perl_sighandler or
+ * Perl_csighandler), or for safe signals, later from
+ * Perl_despatch_signals() at a suitable safe point during execution.
+ *
+ * 'safe' is a boolean indicating the latter call path.
+ */
+
+Signal_t
+Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
+ void *uap PERL_UNUSED_DECL, bool safe)
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
: cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
if (hek)
Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
- "SIG%s handler \"%"HEKf"\" not defined.\n",
+ "SIG%s handler \"%" HEKf "\" not defined.\n",
PL_sig_name[sig], HEKfARG(hek));
/* diag_listed_as: SIG%s handler "%s" not defined */
else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
PUSHSTACKi(PERLSI_SIGNAL);
PUSHMARK(SP);
PUSHs(sv);
+
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
{
struct sigaction oact;
- if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
- if (sip) {
- HV *sih = newHV();
- SV *rv = newRV_noinc(MUTABLE_SV(sih));
- /* The siginfo fields signo, code, errno, pid, uid,
- * addr, status, and band are defined by POSIX/SUSv3. */
- (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
- (void)hv_stores(sih, "code", newSViv(sip->si_code));
-#ifdef HAS_SIGINFO_SI_ERRNO
- (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
-#endif
-#ifdef HAS_SIGINFO_SI_STATUS
- (void)hv_stores(sih, "status", newSViv(sip->si_status));
-#endif
-#ifdef HAS_SIGINFO_SI_UID
- {
- SV *uid = newSV(0);
- sv_setuid(uid, sip->si_uid);
- (void)hv_stores(sih, "uid", uid);
- }
-#endif
-#ifdef HAS_SIGINFO_SI_PID
- (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
-#endif
-#ifdef HAS_SIGINFO_SI_ADDR
- (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
-#endif
-#ifdef HAS_SIGINFO_SI_BAND
- (void)hv_stores(sih, "band", newSViv(sip->si_band));
-#endif
- EXTEND(SP, 2);
- PUSHs(rv);
- mPUSHp((char *)sip, sizeof(*sip));
- }
+ if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
+ HV *sih = newHV();
+ SV *rv = newRV_noinc(MUTABLE_SV(sih));
+ /* The siginfo fields signo, code, errno, pid, uid,
+ * addr, status, and band are defined by POSIX/SUSv3. */
+ (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
+ (void)hv_stores(sih, "code", newSViv(sip->si_code));
+# ifdef HAS_SIGINFO_SI_ERRNO
+ (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
+# endif
+# ifdef HAS_SIGINFO_SI_STATUS
+ (void)hv_stores(sih, "status", newSViv(sip->si_status));
+# endif
+# ifdef HAS_SIGINFO_SI_UID
+ {
+ SV *uid = newSV(0);
+ sv_setuid(uid, sip->si_uid);
+ (void)hv_stores(sih, "uid", uid);
+ }
+# endif
+# ifdef HAS_SIGINFO_SI_PID
+ (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
+# endif
+# ifdef HAS_SIGINFO_SI_ADDR
+ (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
+# endif
+# ifdef HAS_SIGINFO_SI_BAND
+ (void)hv_stores(sih, "band", newSViv(sip->si_band));
+# endif
+ EXTEND(SP, 2);
+ PUSHs(rv);
+ mPUSHp((char *)sip, sizeof(*sip));
}
}
#endif
+
PUTBACK;
errsv_save = newSVsv(ERRSV);
SV * const errsv = ERRSV;
if (SvTRUE_NN(errsv)) {
SvREFCNT_dec(errsv_save);
+
#ifndef PERL_MICRO
- /* Handler "died", for example to get out of a restart-able read().
- * Before we re-do that on its behalf re-enable the signal which was
- * blocked by the system when we entered.
- */
-#ifdef HAS_SIGPROCMASK
-#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
- if (sip || uap)
-#endif
- {
+ /* Handler "died", for example to get out of a restart-able read().
+ * Before we re-do that on its behalf re-enable the signal which was
+ * blocked by the system when we entered.
+ */
+# ifdef HAS_SIGPROCMASK
+ if (!safe) {
+ /* safe signals called via dispatch_signals() set up a
+ * savestack destructor, unblock_sigmask(), to
+ * automatically unblock the handler at the end. If
+ * instead we get here directly, we have to do it
+ * ourselves
+ */
sigset_t set;
sigemptyset(&set);
sigaddset(&set,sig);
sigprocmask(SIG_UNBLOCK, &set, NULL);
}
-#else
+# else
/* Not clear if this will work */
+ /* XXX not clear if this should be protected by 'if (safe)'
+ * too */
+
(void)rsignal(sig, SIG_IGN);
(void)rsignal(sig, PL_csighandlerp);
-#endif
+# endif
#endif /* !PERL_MICRO */
+
die_sv(errsv);
}
else {
}
/*
+=for apidoc_section $magic
=for apidoc magic_sethint
Triggered by a store to C<%^H>, records the key/value pair to
PL_hints |= HINT_LOCALIZE_HH;
CopHINTHASH_set(&PL_compiling,
cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
+ magic_sethint_feature(key, NULL, 0, sv, 0);
return 0;
}
MUTABLE_SV(mg->mg_ptr), 0, 0)
: cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
mg->mg_ptr, mg->mg_len, 0, 0));
+ if (mg->mg_len == HEf_SVKEY)
+ magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
+ else
+ magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
return 0;
}
PERL_UNUSED_ARG(mg);
cophh_free(CopHINTHASH_get(&PL_compiling));
CopHINTHASH_set(&PL_compiling, cophh_new_empty());
+ CLEARFEATUREBITS();
return 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff