#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 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_type == PERL_MAGIC_collxfrm && mg->mg_len >= 0)
+ /* collate magic uses string len not buffer len, so
+ * free even with mg_len == 0 */
+ Safefree(mg->mg_ptr);
+ else 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_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>.
* 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, so do an additional check. */
- if ( ! IN_BYTES /* respect 'use bytes' */
- && ! is_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))
+ 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)
-
-#elif defined(USE_LOCLAE_CTYPE)
+ && _is_cur_LC_category_utf8(LC_MESSAGES)
- /* For systems that don't have a separate message category,
- * this assumes that they follow the CTYPE one */
- && _is_cur_LC_category_utf8(LC_CTYPE)
+#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
) {
}
/*
-=for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv
+=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
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")) {
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') {
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 {
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);
}
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;
PERL_TSA_REQUIRES(PL_dollarzero_mutex)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
const char *s;
STRLEN len;
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
I32 paren;
const REGEXP * rx;
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 */
{
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;
}
{
not_all |= ptr[i] ^ 0x55;
}
if (!not_none) {
- if (!specialWARN(PL_compiling.cop_warnings))
- PerlMemShared_free(PL_compiling.cop_warnings);
- PL_compiling.cop_warnings = pWARN_NONE;
+ free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
} else if (len >= WARNsize && !not_all) {
- 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,
+ 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 ;
- }
+ }
}
}
#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
{
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)
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);
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 {
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;
}