}
}
+int
+Perl_get_extended_os_errno(void)
+{
+
+#if defined(VMS)
+
+ return (int) vaxc$errno;
+
+#elif defined(OS2)
+
+ if (! (_emx_env & 0x200)) { /* Under DOS */
+ return (int) errno;
+ }
+
+ if (errno != errno_isOS2) {
+ const int tmp = _syserrno();
+ if (tmp) /* 2nd call to _syserrno() makes it 0 */
+ Perl_rc = tmp;
+ }
+ return (int) Perl_rc;
+
+#elif defined(WIN32)
+
+ return (int) GetLastError();
+
+#else
+
+ return (int) errno;
+
+#endif
+
+}
+
STATIC void
S_fixup_errno_string(pTHX_ SV* sv)
{
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
break;
case '\005': /* ^E */
- if (nextchar != '\0') {
- if (strEQ(remaining, "NCODING"))
- sv_set_undef(sv);
- break;
- }
+ {
+ if (nextchar != '\0') {
+ if (strEQ(remaining, "NCODING"))
+ sv_set_undef(sv);
+ break;
+ }
#if defined(VMS) || defined(OS2) || defined(WIN32)
+
+ int extended_errno = get_extended_os_errno();
+
# if defined(VMS)
- {
char msg[255];
$DESCRIPTOR(msgdsc,msg);
- sv_setnv(sv,(NV) vaxc$errno);
- if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
+
+ sv_setnv(sv, (NV) extended_errno);
+ if (sys$getmsg(extended_errno,
+ &msgdsc.dsc$w_length,
+ &msgdsc,
+ 0, 0)
+ & 1)
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
else
SvPVCLEAR(sv);
- }
+
#elif defined(OS2)
- if (!(_emx_env & 0x200)) { /* Under DOS */
- sv_setnv(sv, (NV)errno);
- if (errno) {
- utf8ness_t utf8ness;
- const char * errstr = my_strerror(errnum, &utf8ness);
+ if (!(_emx_env & 0x200)) { /* Under DOS */
+ sv_setnv(sv, (NV) extended_errno);
+ if (extended_errno) {
+ utf8ness_t utf8ness;
+ const char * errstr = my_strerror(extended_errno, &utf8ness);
- sv_setpv(sv, errstr);
+ sv_setpv(sv, errstr);
- if (utf8ness == UTF8NESS_YES) {
- SvUTF8_on(sv);
+ if (utf8ness == UTF8NESS_YES) {
+ SvUTF8_on(sv);
+ }
}
+ else {
+ SvPVCLEAR(sv);
+ }
+ } else {
+ sv_setnv(sv, (NV) extended_errno);
+ sv_setpv(sv, os2error(extended_errno));
}
- else {
- SvPVCLEAR(sv);
- }
- } else {
- if (errno != errno_isOS2) {
- const int tmp = _syserrno();
- if (tmp) /* 2nd call to _syserrno() makes it 0 */
- Perl_rc = tmp;
+ if (SvOK(sv) && strNE(SvPVX(sv), "")) {
+ fixup_errno_string(sv);
}
- sv_setnv(sv, (NV)Perl_rc);
- sv_setpv(sv, os2error(Perl_rc));
- }
- if (SvOK(sv) && strNE(SvPVX(sv), "")) {
- fixup_errno_string(sv);
- }
+
# elif defined(WIN32)
- {
- const DWORD dwErr = GetLastError();
- sv_setnv(sv, (NV)dwErr);
+ const DWORD dwErr = (DWORD) extended_errno;
+ sv_setnv(sv, (NV) dwErr);
if (dwErr) {
PerlProc_GetOSError(sv, dwErr);
fixup_errno_string(sv);
else
SvPVCLEAR(sv);
SetLastError(dwErr);
- }
# else
# error Missing code for platform
# endif
break;
#endif /* End of platforms with special handling for $^E; others just fall
through to $! */
+ }
/* FALLTHROUGH */
case '!':
else
sv_set_undef(sv);
}
+ else if (strEQ(remaining, "AST_SUCCESSFUL_PATTERN")) {
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ sv_setrv_inc(sv, MUTABLE_SV(rx));
+ sv_rvweaken(sv);
+ }
+ else
+ sv_set_undef(sv);
+ }
break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
}
}
break;
- case '+':
+ case '+': /* $+ */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = RX_LASTPAREN(rx);
- if (paren)
+ if (paren) {
+ I32 *parno_to_logical = RX_PARNO_TO_LOGICAL(rx);
+ if (parno_to_logical)
+ paren = parno_to_logical[paren];
goto do_numbuf_fetch;
+ }
}
goto set_undef;
- case '\016': /* ^N */
+ case '\016': /* $^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = RX_LASTCLOSEPAREN(rx);
- if (RX_PARNO_TO_LOGICAL(rx))
- paren = RX_PARNO_TO_LOGICAL(rx)[paren];
- if (paren)
+ if (paren) {
+ I32 *parno_to_logical = RX_PARNO_TO_LOGICAL(rx);
+ if (parno_to_logical)
+ paren = parno_to_logical[paren];
goto do_numbuf_fetch;
+ }
}
goto set_undef;
case '.':
return 0;
}
-#ifndef PERL_MICRO
#ifdef HAS_SIGPROCMASK
static void
restore_sigmask(pTHX_ SV *save_sv)
}
+PERL_STACK_REALIGN
#ifdef PERL_USE_3ARG_SIGHANDLER
Signal_t
Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
For magic_clearsig, we don't change the warnings handler if it's
set to the &PL_warnhook. */
svp = &PL_warnhook;
- } else if (sv) {
+ }
+ else if (sv) {
SV *tmp = sv_newmortal();
Perl_croak(aTHX_ "No such hook: %s",
pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
if (i) {
(void)rsignal(i, PL_csighandlerp);
}
- else
+ else {
*svp = SvREFCNT_inc_simple_NN(sv);
+ }
} else {
if (sv && SvOK(sv)) {
s = SvPV_force(sv, len);
SvREFCNT_dec(to_dec);
return 0;
}
-#endif /* !PERL_MICRO */
int
Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
}
int
+Perl_magic_clearhook(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_CLEARHOOK;
+
+ magic_sethook(NULL, mg);
+ return sv_unmagic(sv, mg->mg_type);
+}
+
+/* sv of NULL signifies that we're acting as magic_clearhook. */
+int
+Perl_magic_sethook(pTHX_ SV *sv, MAGIC *mg)
+{
+ SV** svp = NULL;
+ STRLEN len;
+ const char *s = MgPV_const(mg,len);
+
+ PERL_ARGS_ASSERT_MAGIC_SETHOOK;
+
+ if (memEQs(s, len, "require__before")) {
+ svp = &PL_hook__require__before;
+ }
+ else if (memEQs(s, len, "require__after")) {
+ svp = &PL_hook__require__after;
+ }
+ else {
+ SV *tmp = sv_newmortal();
+ Perl_croak(aTHX_ "Attempt to set unknown hook '%s' in %%{^HOOK}",
+ pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
+ }
+ if (sv && SvOK(sv) && (!SvROK(sv) || SvTYPE(SvRV(sv))!= SVt_PVCV))
+ croak("${^HOOK}{%.*s} may only be a CODE reference or undef", (int)len, s);
+
+ if (svp) {
+ if (*svp)
+ SvREFCNT_dec(*svp);
+
+ if (sv)
+ *svp = SvREFCNT_inc_simple_NN(sv);
+ else
+ *svp = NULL;
+ }
+
+ return 0;
+}
+
+int
+Perl_magic_sethookall(pTHX_ SV* sv, MAGIC* mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_SETHOOKALL;
+ PERL_UNUSED_ARG(mg);
+
+ if (PL_localizing == 1) {
+ SAVEGENERICSV(PL_hook__require__before);
+ PL_hook__require__before = NULL;
+ SAVEGENERICSV(PL_hook__require__after);
+ PL_hook__require__after = NULL;
+ }
+ else
+ if (PL_localizing == 2) {
+ HV* hv = (HV*)sv;
+ HE* current;
+ hv_iterinit(hv);
+ while ((current = hv_iternext(hv))) {
+ SV* hookelem = hv_iterval(hv, current);
+ mg_set(hookelem);
+ }
+ }
+ return 0;
+}
+
+int
+Perl_magic_clearhookall(pTHX_ SV* sv, MAGIC* mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_CLEARHOOKALL;
+ PERL_UNUSED_ARG(mg);
+ PERL_UNUSED_ARG(sv);
+
+ SvREFCNT_dec_set_NULL(PL_hook__require__before);
+
+ SvREFCNT_dec_set_NULL(PL_hook__require__after);
+
+ return 0;
+}
+
+
+int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_SETISA;
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
break;
case '^':
- Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ {
+ IO * const io = GvIO(PL_defoutgv);
+ if (!io)
+ break;
+
+ Safefree(IoTOP_NAME(io));
+ IoTOP_NAME(io) = savesvpv(sv);
+ IoTOP_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '~':
- Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ {
+ IO * const io = GvIO(PL_defoutgv);
+ if (!io)
+ break;
+
+ Safefree(IoFMT_NAME(io));
+ IoFMT_NAME(io) = savesvpv(sv);
+ IoFMT_GV(io) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '=':
- IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ {
+ IO * const io = GvIO(PL_defoutgv);
+ if (!io)
+ break;
+
+ IoPAGE_LEN(io) = (SvIV(sv));
+ }
break;
case '-':
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
- if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ {
+ IO * const io = GvIO(PL_defoutgv);
+ if (!io)
+ break;
+
+ IoLINES_LEFT(io) = (SvIV(sv));
+ if (IoLINES_LEFT(io) < 0L)
+ IoLINES_LEFT(io) = 0L;
+ }
break;
case '%':
- IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ {
+ IO * const io = GvIO(PL_defoutgv);
+ if (!io)
+ break;
+
+ IoPAGE(io) = (SvIV(sv));
+ }
break;
case '|':
{
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.
(void)rsignal(sig, SIG_IGN);
(void)rsignal(sig, PL_csighandlerp);
# endif
-#endif /* !PERL_MICRO */
die_sv(errsv);
}
https://perl5.git.perl.org / perl5.git / blobdiff