/* MGS is typedef'ed to struct magic_state in perl.h */
STATIC void
-S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
+S_save_magic_flags(pTHX_ SSize_t mgs_ix, SV *sv, U32 flags)
{
MGS* mgs;
bool bumped = FALSE;
int
Perl_mg_get(pTHX_ SV *sv)
{
- const I32 mgs_ix = SSNEW(sizeof(MGS));
+ const SSize_t mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
bool taint_only = TRUE; /* the only get method seen is taint */
int
Perl_mg_set(pTHX_ SV *sv)
{
- const I32 mgs_ix = SSNEW(sizeof(MGS));
+ const SSize_t mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC* nextmg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
- const I32 mgs_ix = SSNEW(sizeof(MGS));
+ const SSize_t mgs_ix = SSNEW(sizeof(MGS));
I32 len;
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
int
Perl_mg_clear(pTHX_ SV *sv)
{
- const I32 mgs_ix = SSNEW(sizeof(MGS));
+ const SSize_t mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC *nextmg;
const SSize_t n = (SSize_t)mg->mg_obj;
if (n == '+') { /* @+ */
/* return the number possible */
- return RX_NPARENS(rx);
+ return RX_LOGICAL_NPARENS(rx) ? RX_LOGICAL_NPARENS(rx) : RX_NPARENS(rx);
} else { /* @- @^CAPTURE @{^CAPTURE} */
I32 paren = RX_LASTPAREN(rx);
/* return the last filled */
- while ( paren >= 0
- && (RX_OFFS(rx)[paren].start == -1
- || RX_OFFS(rx)[paren].end == -1) )
+ while ( paren >= 0 && !RX_OFFS_VALID(rx,paren) )
paren--;
+ if (paren && RX_PARNO_TO_LOGICAL(rx))
+ paren = RX_PARNO_TO_LOGICAL(rx)[paren];
if (n == '-') {
/* @- */
return (U32)paren;
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
+ REGEXP * const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+
+ if (rx) {
+ 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);
+
+ if (paren < 0)
+ return 0;
- if (PL_curpm) {
- REGEXP * const rx = PM_GETRE(PL_curpm);
- if (rx) {
- 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)
- return 0;
- if (paren <= (I32)RX_NPARENS(rx) &&
- (s = RX_OFFS(rx)[paren].start) != -1 &&
- (t = RX_OFFS(rx)[paren].end) != -1)
+ SSize_t s;
+ SSize_t t;
+ I32 logical_nparens = (I32)RX_LOGICAL_NPARENS(rx);
+
+ if (!logical_nparens)
+ logical_nparens = (I32)RX_NPARENS(rx);
+
+ if (n != '+' && n != '-') {
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ return 0;
+ }
+ if (paren <= (I32)logical_nparens) {
+ I32 true_paren = RX_LOGICAL_TO_PARNO(rx)
+ ? RX_LOGICAL_TO_PARNO(rx)[paren]
+ : paren;
+ do {
+ if (((s = RX_OFFS_START(rx,true_paren)) != -1) &&
+ ((t = RX_OFFS_END(rx,true_paren)) != -1))
{
SSize_t i;
- if (n == '+') /* @+ */
+ if (n == '+') /* @+ */
i = t;
- else if (n == '-') /* @- */
+ else /* @- */
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_setuv(sv, i);
return 0;
}
+ if (RX_PARNO_TO_LOGICAL_NEXT(rx))
+ true_paren = RX_PARNO_TO_LOGICAL_NEXT(rx)[true_paren];
+ else
+ break;
+ } while (true_paren);
}
}
sv_set_undef(sv);
}
}
+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') {
sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
- sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
- *PL_compiling.cop_warnings);
+ sv_setpvn(sv, PL_compiling.cop_warnings,
+ RCPV_LEN(PL_compiling.cop_warnings));
}
}
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 (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;
I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
while (items--) {
stash = GvSTASH((GV *)*svp++);
- if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
+ if (stash && HvHasENAME(stash)) mro_isa_changed_in(stash);
}
return 0;
/* The stash may have been detached from the symbol table, so check its
name before doing anything. */
- if (stash && HvENAME_get(stash))
+ if (stash && HvHasENAME(stash))
mro_isa_changed_in(stash);
return 0;
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);
+ free_and_set_cop_warnings(
+ &PL_compiling,
+ Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+ p, len)
+ );
if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
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