#endif
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Signal_t Perl_csighandler(int sig, ...);
+Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
#else
Signal_t Perl_csighandler(int sig);
#endif
{
dVAR;
MGS* mgs;
+
+ PERL_ARGS_ASSERT_SAVE_MAGIC;
+
assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
Perl_mg_magical(pTHX_ SV *sv)
{
const MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_MAGICAL;
PERL_UNUSED_CONTEXT;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
- if (vtbl) {
- if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
- SvGMAGICAL_on(sv);
- if (vtbl->svt_set)
- SvSMAGICAL_on(sv);
- if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
- SvRMAGICAL_on(sv);
- }
+ if ((mg = SvMAGIC(sv))) {
+ SvRMAGICAL_off(sv);
+ do {
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if (vtbl) {
+ if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
+ SvGMAGICAL_on(sv);
+ if (vtbl->svt_set)
+ SvSMAGICAL_on(sv);
+ if (vtbl->svt_clear)
+ SvRMAGICAL_on(sv);
+ }
+ } while ((mg = mg->mg_moremagic));
+ if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
+ SvRMAGICAL_on(sv);
}
}
STATIC bool
S_is_container_magic(const MAGIC *mg)
{
+ assert(mg);
switch (mg->mg_type) {
case PERL_MAGIC_bm:
case PERL_MAGIC_fm:
/* guard against sv having being freed midway by holding a private
reference. */
+ PERL_ARGS_ASSERT_MG_GET;
+
/* sv_2mortal has this side effect of turning on the TEMP flag, which can
cause the SV's buffer to get stolen (and maybe other stuff).
So restore it.
MAGIC* mg;
MAGIC* nextmg;
+ PERL_ARGS_ASSERT_MG_SET;
+
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = nextmg) {
MAGIC* mg;
STRLEN len;
+ PERL_ARGS_ASSERT_MG_LENGTH;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL * const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
}
}
- if (DO_UTF8(sv)) {
+ {
+ /* You can't know whether it's UTF-8 until you get the string again...
+ */
const U8 *s = (U8*)SvPV_const(sv, len);
- len = utf8_length(s, s + len);
+
+ if (DO_UTF8(sv)) {
+ len = utf8_length(s, s + len);
+ }
}
- else
- (void)SvPV_const(sv, len);
return len;
}
{
MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_SIZE;
+
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));
MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_CLEAR;
+
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
{
int count = 0;
MAGIC* mg;
+
+ PERL_ARGS_ASSERT_MG_COPY;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
{
dVAR;
MAGIC *mg;
+
+ PERL_ARGS_ASSERT_MG_LOCALIZE;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (!S_is_container_magic(mg))
{
MAGIC* mg;
MAGIC* moremagic;
+
+ PERL_ARGS_ASSERT_MG_FREE;
+
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
moremagic = mg->mg_moremagic;
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
+ SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
+ SvMAGICAL_off(sv);
return 0;
}
dVAR;
PERL_UNUSED_ARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
if (mg->mg_obj) { /* @+ */
/* return the number possible */
- return rx->nparens;
+ return RX_NPARENS(rx);
} else { /* @- */
- I32 paren = rx->lastparen;
+ I32 paren = RX_LASTPAREN(rx);
/* return the last filled */
while ( paren >= 0
- && (rx->offs[paren].start == -1
- || rx->offs[paren].end == -1) )
+ && (RX_OFFS(rx)[paren].start == -1
+ || RX_OFFS(rx)[paren].end == -1) )
paren--;
return (U32)paren;
}
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
register I32 t;
if (paren < 0)
return 0;
- if (paren <= (I32)rx->nparens &&
- (s = rx->offs[paren].start) != -1 &&
- (t = rx->offs[paren].end) != -1)
+ if (paren <= (I32)RX_NPARENS(rx) &&
+ (s = RX_OFFS(rx)[paren].start) != -1 &&
+ (t = RX_OFFS(rx)[paren].end) != -1)
{
register I32 i;
if (mg->mg_obj) /* @+ */
i = s;
if (i > 0 && RX_MATCH_UTF8(rx)) {
- const char * const b = rx->subbeg;
+ const char * const b = RX_SUBBEG(rx);
if (b)
i = utf8_length((U8*)b, (U8*)(b+i));
}
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_ PL_no_modify);
register const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
+ PERL_ARGS_ASSERT_MAGIC_LEN;
+
switch (*mg->mg_ptr) {
case '\020':
if (*remaining == '\0') { /* ^P */
}
case '`':
do_prematch:
- paren = -2;
+ paren = RX_BUFF_IDX_PREMATCH;
goto maybegetparen;
case '\'':
do_postmatch:
- paren = -1;
+ paren = RX_BUFF_IDX_POSTMATCH;
goto maybegetparen;
case '&':
do_match:
- paren = 0;
+ paren = RX_BUFF_IDX_FULLMATCH;
goto maybegetparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
}
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastparen;
+ paren = RX_LASTPAREN(rx);
if (paren)
goto getparen;
}
return 0;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastcloseparen;
+ paren = RX_LASTCLOSEPAREN(rx);
if (paren)
goto getparen;
}
void
Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
{
+ PERL_ARGS_ASSERT_EMULATE_COP_IO;
+
if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
sv_setsv(sv, &PL_sv_undef);
else {
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
+ PERL_ARGS_ASSERT_MAGIC_GET;
+
switch (*mg->mg_ptr) {
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
sv_setiv(sv, (IV)PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
- if (PL_inplace)
- sv_setpv(sv, PL_inplace);
- else
- sv_setsv(sv, &PL_sv_undef);
+ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
break;
case '\023': /* ^S */
if (nextchar == '\0') {
- if (PL_lex_state != LEX_NOTPARSING)
+ if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->lastparen) {
- CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
+ if (RX_LASTPAREN(rx)) {
+ CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
break;
}
}
break;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->lastcloseparen) {
- CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
+ if (RX_LASTCLOSEPAREN(rx)) {
+ CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
break;
}
sv_setpv(sv,s);
else {
sv_setpv(sv,GvENAME(PL_defoutgv));
- sv_catpv(sv,"_TOP");
+ sv_catpvs(sv,"_TOP");
}
break;
case '~':
{
struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_GETUVAR;
+
if (uf && uf->uf_val)
(*uf->uf_val)(aTHX_ uf->uf_index, sv);
return 0;
const char * const ptr = MgPV_const(mg,klen);
my_setenv(ptr, s);
+ PERL_ARGS_ASSERT_MAGIC_SETENV;
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARENV;
PERL_UNUSED_ARG(sv);
my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
PERL_UNUSED_ARG(mg);
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
#if defined(VMS)
dVAR;
/* Are we fetching a signal entry? */
const I32 i = whichsig(MgPV_nolen_const(mg));
+
+ PERL_ARGS_ASSERT_MAGIC_GETSIG;
+
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
*/
dVAR;
register const char * const s = MgPV_nolen_const(mg);
+ PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
PERL_UNUSED_ARG(sv);
if (*s == '_') {
SV** svp = NULL;
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
+ save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
return 0;
}
-/*
- * The signal handling nomenclature has gotten a bit confusing since the advent of
- * safe signals. S_raise_signal only raises signals by analogy with what the
- * underlying system's signal mechanism does. It might be more proper to say that
- * it defers signals that have already been raised and caught.
- *
- * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
- * in the sense of being on the system's signal queue in between raising and delivery.
- * They are only pending on Perl's deferral list, i.e., they track deferred signals
- * awaiting delivery after the current Perl opcode completes and say nothing about
- * signals raised but not yet caught in the underlying signal implementation.
- */
-
-#ifndef SIG_PENDING_DIE_COUNT
-# define SIG_PENDING_DIE_COUNT 120
-#endif
-
-static void
-S_raise_signal(pTHX_ int sig)
-{
- dVAR;
- /* Set a flag to say this signal is pending */
- PL_psig_pend[sig]++;
- /* And one to say _a_ signal is pending */
- if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
- Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
- (unsigned long)SIG_PENDING_DIE_COUNT);
-}
-
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_csighandler(int sig, ...)
+Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
#else
Perl_csighandler(int sig)
#endif
exit(1);
#endif
#endif
- if (
+ if (
#ifdef SIGILL
sig == SIGILL ||
#endif
(PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
* with risk we may be in malloc() etc. */
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
- else
- S_raise_signal(aTHX_ sig);
+#endif
+ else {
+ /* Set a flag to say this signal is pending, that is awaiting delivery after
+ * the current Perl opcode completes */
+ PL_psig_pend[sig]++;
+
+#ifndef SIG_PENDING_DIE_COUNT
+# define SIG_PENDING_DIE_COUNT 120
+#endif
+ /* And one to say _a_ signal is pending */
+ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+ Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+ (unsigned long)SIG_PENDING_DIE_COUNT);
+ }
}
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
PERL_BLOCKSIG_ADD(set, sig);
PL_psig_pend[sig] = 0;
PERL_BLOCKSIG_BLOCK(set);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
+#endif
PERL_BLOCKSIG_UNBLOCK(set);
}
}
sigset_t set, save;
SV* save_sv;
#endif
-
register const char *s = MgPV_const(mg,len);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSIG;
+
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
+ save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
PL_psig_name[i] = newSVpvn(s, len);
SvREADONLY_on(PL_psig_name[i]);
}
- if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
+ if (isGV_with_GP(sv) || SvROK(sv)) {
if (i) {
(void)rsignal(i, PL_csighandlerp);
#ifdef HAS_SIGPROCMASK
* tell whether HINT_STRICT_REFS is in force or not.
*/
if (!strchr(s,':') && !strchr(s,'\''))
- Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
+ Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
+ SV_GMAGIC);
if (i)
(void)rsignal(i, PL_csighandlerp);
else
{
dVAR;
HV* stash;
+
+ PERL_ARGS_ASSERT_MAGIC_SETISA;
PERL_UNUSED_ARG(sv);
/* Bail out if destruction is going on */
if(PL_dirty) return 0;
+ /* Skip _isaelem because _isa will handle it shortly */
+ if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
+ return 0;
+
+ /* XXX Once it's possible, we need to
+ detect that our @ISA is aliased in
+ other stashes, and act on the stashes
+ of all of the aliases */
+
/* The first case occurs via setisa,
the second via setisa_elem, which
calls this same magic */
stash = GvSTASH(
SvTYPE(mg->mg_obj) == SVt_PVGV
? (GV*)mg->mg_obj
- : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
+ : (GV*)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
);
- if(PL_delaymagic)
- PL_delayedisa = stash;
- else
- mro_isa_changed_in(stash);
+ if (stash)
+ mro_isa_changed_in(stash);
+
+ return 0;
+}
+
+int
+Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+ HV* stash;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARISA;
+
+ /* Bail out if destruction is going on */
+ if(PL_dirty) return 0;
+
+ av_clear((AV*)sv);
+
+ /* XXX see comments in magic_setisa */
+ stash = GvSTASH(
+ SvTYPE(mg->mg_obj) == SVt_PVGV
+ ? (GV*)mg->mg_obj
+ : (GV*)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
+ );
+
+ if (stash)
+ mro_isa_changed_in(stash);
return 0;
}
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
PL_amagic_generation++;
{
HV * const hv = (HV*)LvTARG(sv);
I32 i = 0;
+
+ PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
PERL_UNUSED_ARG(mg);
if (hv) {
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
PERL_UNUSED_ARG(mg);
if (LvTARG(sv)) {
hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
dVAR;
dSP;
+ PERL_ARGS_ASSERT_MAGIC_METHCALL;
+
PUSHMARK(SP);
EXTEND(SP, n);
PUSHs(SvTIED_obj(sv, mg));
if (n > 1) {
if (mg->mg_ptr) {
if (mg->mg_len >= 0)
- PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
+ mPUSHp(mg->mg_ptr, mg->mg_len);
else if (mg->mg_len == HEf_SVKEY)
PUSHs((SV*)mg->mg_ptr);
}
else if (mg->mg_type == PERL_MAGIC_tiedelem) {
- PUSHs(sv_2mortal(newSViv(mg->mg_len)));
+ mPUSHi(mg->mg_len);
}
}
if (n > 2) {
{
dVAR; dSP;
+ PERL_ARGS_ASSERT_MAGIC_METHPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
int
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_GETPACK;
+
if (mg->mg_ptr)
mg->mg_flags |= MGf_GSKIP;
magic_methpack(sv,mg,"FETCH");
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
dVAR; dSP;
+
+ PERL_ARGS_ASSERT_MAGIC_SETPACK;
+
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
int
Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
+
return magic_methpack(sv,mg,"DELETE");
}
dVAR; dSP;
I32 retval = 0;
+ PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
{
dVAR; dSP;
+ PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
+
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
dVAR; dSP;
const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
+ PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
+
ENTER;
SAVETMPS;
PUSHSTACKi(PERLSI_MAGIC);
int
Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
+
return magic_methpack(sv,mg,"EXISTS");
}
SV * const tied = SvTIED_obj((SV*)hv, mg);
HV * const pkg = SvSTASH((SV*)SvRV(tied));
+ PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
+
if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
SV *key;
if (HvEITER_get(hv))
const I32 i = SvTRUE(sv);
SV ** const svp = av_fetch(GvAV(gv),
atoi(MgPV_nolen_const(mg)), FALSE);
+
+ PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
+
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
{
dVAR;
const AV * const obj = (AV*)mg->mg_obj;
+
+ PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
+
if (obj) {
sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
} else {
{
dVAR;
AV * const obj = (AV*)mg->mg_obj;
+
+ PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
+
if (obj) {
av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
} else {
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
PERL_UNUSED_ARG(sv);
+
/* during global destruction, mg_obj may already have been freed */
if (PL_in_clean_all)
return 0;
{
dVAR;
SV* const lsv = LvTARG(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETPOS;
PERL_UNUSED_ARG(mg);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
STRLEN ulen = 0;
MAGIC* found;
+ PERL_ARGS_ASSERT_MAGIC_SETPOS;
PERL_UNUSED_ARG(mg);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
}
int
-Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
-{
- GV* gv;
- PERL_UNUSED_ARG(mg);
-
- Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
-
- if (!SvOK(sv))
- return 0;
- if (isGV_with_GP(sv)) {
- /* We're actually already a typeglob, so don't need the stuff below.
- */
- return 0;
- }
- gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
- if (sv == (SV*)gv)
- return 0;
- if (GvGP(sv))
- gp_free((GV*)sv);
- GvGP(sv) = gp_ref(GvGP(gv));
- return 0;
-}
-
-int
Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len;
const char * const tmps = SvPV_const(lsv,len);
I32 offs = LvTARGOFF(sv);
I32 rem = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
if (SvUTF8(lsv))
SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
if (DO_UTF8(sv)) {
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
+
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
}
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_SETTAINT;
PERL_UNUSED_ARG(sv);
+
/* update taint status */
if (PL_tainted)
mg->mg_len |= 1;
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
if (lsv)
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETVEC;
PERL_UNUSED_ARG(mg);
do_vecset(sv); /* XXX slurp this routine */
return 0;
{
dVAR;
SV *targ = NULL;
+
+ PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
+
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
PERL_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
vivify_defelem(sv);
MAGIC *mg;
SV *value = NULL;
+ PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
+
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
}
int
Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
PERL_UNUSED_CONTEXT;
mg->mg_len = -1;
SvSCREAM_off(sv);
}
int
-Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
-{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_bm);
- SvTAIL_off(sv);
- SvVALID_off(sv);
- return 0;
-}
-
-int
-Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
-{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_fm);
- SvCOMPILED_off(sv);
- return 0;
-}
-
-int
Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
{
const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_SETUVAR;
+
if (uf && uf->uf_set)
(*uf->uf_set)(aTHX_ uf->uf_index, sv);
return 0;
int
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_qr);
- return 0;
-}
+ const char type = mg->mg_type;
-int
-Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- regexp * const re = (regexp *)mg->mg_obj;
- PERL_UNUSED_ARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
- ReREFCNT_dec(re);
- return 0;
+ if (type == PERL_MAGIC_qr) {
+ } else if (type == PERL_MAGIC_bm) {
+ SvTAIL_off(sv);
+ SvVALID_off(sv);
+ } else {
+ assert(type == PERL_MAGIC_fm);
+ SvCOMPILED_off(sv);
+ }
+ return sv_unmagic(sv, type);
}
#ifdef USE_LOCALE_COLLATE
int
Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
+
/*
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
int
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETUTF8;
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
I32 i;
STRLEN len;
+ PERL_ARGS_ASSERT_MAGIC_SET;
+
switch (*mg->mg_ptr) {
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH"))
goto do_match;
case '`': /* ${^PREMATCH} caught below */
do_prematch:
- paren = -2;
+ paren = RX_BUFF_IDX_PREMATCH;
goto setparen;
case '\'': /* ${^POSTMATCH} caught below */
do_postmatch:
- paren = -1;
+ paren = RX_BUFF_IDX_POSTMATCH;
goto setparen;
case '&':
do_match:
- paren = 0;
+ paren = RX_BUFF_IDX_FULLMATCH;
goto setparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
+ paren = atoi(mg->mg_ptr);
setparen:
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
break;
- } else {
+ } else {
/* Croak with a READONLY error when a numbered match var is
* set without a previous pattern match. Unless it's C<local $1>
*/
/* Opening for input is more common than opening for output, so
ensure that hints for input are sooner on linked list. */
- tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
- : newSVpvs(""));
- SvFLAGS(tmp) |= SvUTF8(sv);
+ tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
+ SVs_TEMP | SvUTF8(sv))
+ : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
tmp_he
= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
- sv_2mortal(newSVpvs("open>")), tmp);
+ newSVpvs_flags("open>", SVs_TEMP),
+ tmp);
/* The UTF-8 setting is carried over */
sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
PL_compiling.cop_hints_hash
= Perl_refcounted_he_new(aTHX_ tmp_he,
- sv_2mortal(newSVpvs("open<")), tmp);
+ newSVpvs_flags("open<", SVs_TEMP),
+ tmp);
}
break;
case '\020': /* ^P */
Perl_whichsig(pTHX_ const char *sig)
{
register char* const* sigv;
+
+ PERL_ARGS_ASSERT_WHICHSIG;
PERL_UNUSED_CONTEXT;
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, ...)
+Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
#else
Perl_sighandler(int sig)
#endif
struct sigaction oact;
if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
- siginfo_t *sip;
- va_list args;
-
- va_start(args, sig);
- sip = (siginfo_t*)va_arg(args, siginfo_t*);
if (sip) {
HV *sih = newHV();
SV *rv = newRV_noinc((SV*)sih);
/* The siginfo fields signo, code, errno, pid, uid,
* addr, status, and band are defined by POSIX/SUSv3. */
- hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
- hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
+ (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
+ (void)hv_stores(sih, "code", newSViv(sip->si_code));
#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
- hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
- hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
- hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
- hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
- hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
- hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
+ hv_stores(sih, "errno", newSViv(sip->si_errno));
+ hv_stores(sih, "status", newSViv(sip->si_status));
+ hv_stores(sih, "uid", newSViv(sip->si_uid));
+ hv_stores(sih, "pid", newSViv(sip->si_pid));
+ hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
+ hv_stores(sih, "band", newSViv(sip->si_band));
#endif
EXTEND(SP, 2);
PUSHs((SV*)rv);
- PUSHs(newSVpv((char *)sip, sizeof(*sip)));
+ mPUSHp((char *)sip, sizeof(*sip));
}
- va_end(args);
}
}
#endif
dVAR;
const U32 flags = *(const U32*)p;
+ PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
+
if (flags & 1)
PL_savestack_ix -= 5; /* Unprotect save in progress. */
#if !defined(PERL_IMPLICIT_CONTEXT)
Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- assert(mg->mg_len == HEf_SVKEY);
+ SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
+ : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
+
+ PERL_ARGS_ASSERT_MAGIC_SETHINT;
/* mg->mg_obj isn't being used. If needed, it would be possible to store
an alternative leaf in there, with PL_compiling.cop_hints being used if
forgetting to do it, and consequent subtle errors. */
PL_hints |= HINT_LOCALIZE_HH;
PL_compiling.cop_hints_hash
- = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
- (SV *)mg->mg_ptr, sv);
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
return 0;
}
/*
-=for apidoc magic_sethint
+=for apidoc magic_clearhint
Triggered by a delete from %^H, records the key to
C<PL_compiling.cop_hints_hash>.
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
assert(mg->mg_len == HEf_SVKEY);
https://perl5.git.perl.org / perl5.git / blobdiff