#include "perl.h"
#include "regcomp.h"
+#ifndef HAS_C99
+# if __STDC_VERSION__ >= 199901L && !defined(VMS)
+# define HAS_C99 1
+# endif
+#endif
+#if HAS_C99
+# include <stdint.h>
+#endif
+
#define FCALL *f
#ifdef __Lynx__
contains fields specific to each type. Some types store all they need
in the head, so don't have a body.
-In all but the most memory-paranoid configuations (ex: PURIFY), heads
+In all but the most memory-paranoid configurations (ex: PURIFY), heads
and bodies are allocated out of arenas, which by default are
approximately 4K chunks of memory parcelled up into N heads or bodies.
Sv-bodies are allocated by their sv-type, guaranteeing size
SvREFCNT_dec(sv); /* undo the inc above */
}
+/* Void wrapper to pass to visit() */
+static void
+do_curse(pTHX_ SV * const sv) {
+ if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
+ || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
+ return;
+ (void)curse(sv, 0);
+}
+
/*
=for apidoc sv_clean_objs
* error messages, close files etc */
visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
+ /* And if there are some very tenacious barnacles clinging to arrays,
+ closures, or what have you.... */
+ visit(do_curse, SVs_OBJECT, SVs_OBJECT);
olddef = PL_defoutgv;
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
if (olddef && isGV_with_GP(olddef))
Remember, this is integer division: */
end = start + good_arena_size / body_size * body_size;
- /* computed count doesnt reflect the 1st slot reservation */
+ /* computed count doesn't reflect the 1st slot reservation */
#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d (from %d) type %d "
SV * tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr=AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvIV(tmpstr);
}
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr = AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvUV(tmpstr);
}
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return 0;
- tmpstr = AMG_CALLun(sv,numer);
+ tmpstr = AMG_CALLunary(sv, numer_amg);
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
return SvNV(tmpstr);
}
if (!SvROK(sv))
return sv;
if (SvAMAGIC(sv)) {
- SV * const tmpsv = AMG_CALLun(sv,numer);
+ SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
TAINT_IF(tmpsv && SvTAINTED(tmpsv));
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return sv_2num(tmpsv);
SV *tmpstr;
if (flags & SV_SKIP_OVERLOAD)
return NULL;
- tmpstr = AMG_CALLun(sv,string);
+ tmpstr = AMG_CALLunary(sv, string_amg);
TAINT_IF(tmpstr && SvTAINTED(tmpstr));
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
/* Unwrap this: */
retval -= stashnamelen;
memcpy(retval, stashname, stashnamelen);
}
- /* retval may not neccesarily have reached the start of the
+ /* retval may not necessarily have reached the start of the
buffer here. */
assert (retval >= buffer);
return 0;
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
- SV * const tmpsv = AMG_CALLun(sv,bool_);
+ SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return cBOOL(SvTRUE(tmpsv));
}
if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
mro_package_moved(
stash, old_stash,
- (GV *)dstr, NULL, 0
+ (GV *)dstr, 0
);
}
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
) {
mro_package_moved(
(HV *)sref, (HV *)dref,
- (GV *)dstr, NULL, 0
+ (GV *)dstr, 0
);
}
}
else if (
- stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")
+ stype == SVt_PVAV && sref != dref
+ && strEQ(GvNAME((GV*)dstr), "ISA")
/* The stash may have been detached from the symbol table, so
check its name before doing anything. */
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
) {
MAGIC *mg;
+ MAGIC * const omg = dref && SvSMAGICAL(dref)
+ ? mg_find(dref, PERL_MAGIC_isa)
+ : NULL;
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
AV * const ary = newAV();
av_push(ary, mg->mg_obj); /* takes the refcount */
mg->mg_obj = (SV *)ary;
}
- av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
+ if (omg) {
+ if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
+ SV **svp = AvARRAY((AV *)omg->mg_obj);
+ I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
+ while (items--)
+ av_push(
+ (AV *)mg->mg_obj,
+ SvREFCNT_inc_simple_NN(*svp++)
+ );
+ }
+ else
+ av_push(
+ (AV *)mg->mg_obj,
+ SvREFCNT_inc_simple_NN(omg->mg_obj)
+ );
+ }
+ else
+ av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
}
- else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
- mro_isa_changed_in(GvSTASH(dstr));
+ else
+ {
+ sv_magic(
+ sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
+ );
+ mg = mg_find(sref, PERL_MAGIC_isa);
+ }
+ /* Since the *ISA assignment could have affected more than
+ one stash, don’t call mro_isa_changed_in directly, but let
+ magic_clearisa do it for us, as it already has the logic for
+ dealing with globs vs arrays of globs. */
+ assert(mg);
+ Perl_magic_clearisa(aTHX_ NULL, mg);
}
break;
}
)
mro_package_moved(
stash, old_stash,
- (GV *)dstr, NULL, 0
+ (GV *)dstr, 0
);
}
}
#endif
if (flags & SV_HAS_TRAILING_NUL) {
/* It's long enough - do nothing.
- Specfically Perl_newCONSTSUB is relying on this. */
+ Specifically Perl_newCONSTSUB is relying on this. */
} else {
#ifdef DEBUGGING
/* Force a move to shake out bugs in callers. */
else if (SvFAKE(sv) && isGV_with_GP(sv))
sv_unglob(sv);
else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
- /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
+ /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
to sv_unglob. We only need it here, so inline it. */
const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
SV *const temp = newSV_type(new_type);
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY) {
/* Yes, this is casting away const. This is only for the case of
- HEf_SVKEY. I think we need to document this abberation of the
+ HEf_SVKEY. I think we need to document this aberation of the
constness of the API, rather than making name non-const, as
that change propagating outwards a long way. */
mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
}
}
-/*
-=for apidoc sv_unmagic
-
-Removes all magic of type C<type> from an SV.
-
-=cut
-*/
-
int
-Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
{
MAGIC* mg;
MAGIC** mgp;
- PERL_ARGS_ASSERT_SV_UNMAGIC;
+ assert(flags <= 1);
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
return 0;
mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
for (mg = *mgp; mg; mg = *mgp) {
- if (mg->mg_type == type) {
- const MGVTBL* const vtbl = mg->mg_virtual;
+ const MGVTBL* const virt = mg->mg_virtual;
+ if (mg->mg_type == type && (!flags || virt == vtbl)) {
*mgp = mg->mg_moremagic;
- if (vtbl && vtbl->svt_free)
- vtbl->svt_free(aTHX_ sv, mg);
+ if (virt && virt->svt_free)
+ virt->svt_free(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
if (mg->mg_len > 0)
Safefree(mg->mg_ptr);
}
/*
+=for apidoc sv_unmagic
+
+Removes all magic of type C<type> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
+{
+ PERL_ARGS_ASSERT_SV_UNMAGIC;
+ return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
+}
+
+/*
+=for apidoc sv_unmagicext
+
+Removes all magic of type C<type> with the specified C<vtbl> from an SV.
+
+=cut
+*/
+
+int
+Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
+{
+ PERL_ARGS_ASSERT_SV_UNMAGICEXT;
+ return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
+}
+
+/*
=for apidoc sv_rvweaken
Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
}
if (SvOBJECT(sv)) {
- if (PL_defstash && /* Still have a symbol table? */
- SvDESTROYABLE(sv))
- {
- dSP;
- HV* stash;
- do {
- CV* destructor;
- stash = SvSTASH(sv);
- destructor = StashHANDLER(stash,DESTROY);
- if (destructor
- /* A constant subroutine can have no side effects, so
- don't bother calling it. */
- && !CvCONST(destructor)
- /* Don't bother calling an empty destructor */
- && (CvISXSUB(destructor)
- || (CvSTART(destructor)
- && (CvSTART(destructor)->op_next->op_type
- != OP_LEAVESUB))))
- {
- SV* const tmpref = newRV(sv);
- SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
- ENTER;
- PUSHSTACKi(PERLSI_DESTROY);
- EXTEND(SP, 2);
- PUSHMARK(SP);
- PUSHs(tmpref);
- PUTBACK;
- call_sv(MUTABLE_SV(destructor),
- G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
- POPSTACK;
- SPAGAIN;
- LEAVE;
- if(SvREFCNT(tmpref) < 2) {
- /* tmpref is not kept alive! */
- SvREFCNT(sv)--;
- SvRV_set(tmpref, NULL);
- SvROK_off(tmpref);
- }
- SvREFCNT_dec(tmpref);
- }
- } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
-
-
- if (SvREFCNT(sv)) {
- if (PL_in_clean_objs)
- Perl_croak(aTHX_
- "DESTROY created new reference to dead object '%s'",
- HvNAME_get(stash));
- /* DESTROY gave object new lease on life */
- goto get_next_sv;
- }
- }
-
- if (SvOBJECT(sv)) {
- SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
- SvOBJECT_off(sv); /* Curse the object. */
- if (type != SVt_PVIO)
- --PL_sv_objcount;/* XXX Might want something more general */
- }
+ if (!curse(sv, 1)) goto get_next_sv;
}
if (type >= SVt_PVMG) {
if (type == SVt_PVMG && SvPAD_OUR(sv)) {
PL_last_swash_hv = NULL;
}
Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
- hv_undef(MUTABLE_HV(sv));
+ Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
break;
case SVt_PVAV:
{
} /* while sv */
}
+/* This routine curses the sv itself, not the object referenced by sv. So
+ sv does not have to be ROK. */
+
+static bool
+S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
+ dVAR;
+
+ PERL_ARGS_ASSERT_CURSE;
+ assert(SvOBJECT(sv));
+
+ if (PL_defstash && /* Still have a symbol table? */
+ SvDESTROYABLE(sv))
+ {
+ dSP;
+ HV* stash;
+ do {
+ CV* destructor;
+ stash = SvSTASH(sv);
+ destructor = StashHANDLER(stash,DESTROY);
+ if (destructor
+ /* A constant subroutine can have no side effects, so
+ don't bother calling it. */
+ && !CvCONST(destructor)
+ /* Don't bother calling an empty destructor */
+ && (CvISXSUB(destructor)
+ || (CvSTART(destructor)
+ && (CvSTART(destructor)->op_next->op_type
+ != OP_LEAVESUB))))
+ {
+ SV* const tmpref = newRV(sv);
+ SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
+ ENTER;
+ PUSHSTACKi(PERLSI_DESTROY);
+ EXTEND(SP, 2);
+ PUSHMARK(SP);
+ PUSHs(tmpref);
+ PUTBACK;
+ call_sv(MUTABLE_SV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
+ POPSTACK;
+ SPAGAIN;
+ LEAVE;
+ if(SvREFCNT(tmpref) < 2) {
+ /* tmpref is not kept alive! */
+ SvREFCNT(sv)--;
+ SvRV_set(tmpref, NULL);
+ SvROK_off(tmpref);
+ }
+ SvREFCNT_dec(tmpref);
+ }
+ } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+
+ if (check_refcnt && SvREFCNT(sv)) {
+ if (PL_in_clean_objs)
+ Perl_croak(aTHX_
+ "DESTROY created new reference to dead object '%s'",
+ HvNAME_get(stash));
+ /* DESTROY gave object new lease on life */
+ return FALSE;
+ }
+ }
+
+ if (SvOBJECT(sv)) {
+ SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ SvOBJECT_off(sv); /* Curse the object. */
+ if (SvTYPE(sv) != SVt_PVIO)
+ --PL_sv_objcount;/* XXX Might want something more general */
+ }
+ return TRUE;
+}
+
/*
=for apidoc sv_newref
/* Cache has 2 slots in use, and we know three potential pairs.
Keep the two that give the lowest RMS distance. Do the
- calcualation in bytes simply because we always know the byte
+ calculation in bytes simply because we always know the byte
length. squareroot has the same ordering as the positive value,
so don't bother with the actual square root. */
const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
#endif /* USE_LOCALE_COLLATE */
+static char *
+S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+ SV * const tsv = newSV(0);
+ ENTER;
+ SAVEFREESV(tsv);
+ sv_gets(tsv, fp, 0);
+ sv_utf8_upgrade_nomg(tsv);
+ SvCUR_set(sv,append);
+ sv_catsv(sv,tsv);
+ LEAVE;
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+
+static char *
+S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
+{
+ I32 bytesread;
+ const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
+ /* Grab the size of the record we're getting */
+ char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
+#ifdef VMS
+ int fd;
+#endif
+
+ /* Go yank in */
+#ifdef VMS
+ /* VMS wants read instead of fread, because fread doesn't respect */
+ /* RMS record boundaries. This is not necessarily a good thing to be */
+ /* doing, but we've got no other real choice - except avoid stdio
+ as implementation - perhaps write a :vms layer ?
+ */
+ fd = PerlIO_fileno(fp);
+ if (fd != -1) {
+ bytesread = PerlLIO_read(fd, buffer, recsize);
+ }
+ else /* in-memory file from PerlIO::Scalar */
+#endif
+ {
+ bytesread = PerlIO_read(fp, buffer, recsize);
+ }
+
+ if (bytesread < 0)
+ bytesread = 0;
+ SvCUR_set(sv, bytesread + append);
+ buffer[bytesread] = '\0';
+ return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
+}
+
/*
=for apidoc sv_gets
sv_pos_u2b(sv,&append,0);
}
} else if (SvUTF8(sv)) {
- SV * const tsv = newSV(0);
- ENTER;
- SAVEFREESV(tsv);
- sv_gets(tsv, fp, 0);
- sv_utf8_upgrade_nomg(tsv);
- SvCUR_set(sv,append);
- sv_catsv(sv,tsv);
- LEAVE;
- goto return_string_or_null;
+ return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append);
}
}
rslen = 0;
}
else if (RsRECORD(PL_rs)) {
- I32 bytesread;
- char *buffer;
- U32 recsize;
-#ifdef VMS
- int fd;
-#endif
-
- /* Grab the size of the record we're getting */
- recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
- buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
- /* Go yank in */
-#ifdef VMS
- /* VMS wants read instead of fread, because fread doesn't respect */
- /* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice - except avoid stdio
- as implementation - perhaps write a :vms layer ?
- */
- fd = PerlIO_fileno(fp);
- if (fd == -1) { /* in-memory file from PerlIO::Scalar */
- bytesread = PerlIO_read(fp, buffer, recsize);
- }
- else {
- bytesread = PerlLIO_read(fd, buffer, recsize);
- }
-#else
- bytesread = PerlIO_read(fp, buffer, recsize);
-#endif
- if (bytesread < 0)
- bytesread = 0;
- SvCUR_set(sv, bytesread + append);
- buffer[bytesread] = '\0';
- goto return_string_or_null;
+ return S_sv_gets_read_record(aTHX_ sv, fp, append);
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
+ assert (!shortbuffered);
+ goto cannot_be_shortbuffered;
}
}
continue;
}
+ cannot_be_shortbuffered:
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
PTR2UV(ptr),(long)cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
-#if 0
- DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+ DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
-#endif
+
/* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
-#if 0
- DEBUG_P(PerlIO_printf(Perl_debug_log,
+
+ DEBUG_Pv(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
-#endif
+
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
}
else {
cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
- /* Accomodate broken VAXC compiler, which applies U8 cast to
+ /* Accommodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
if (cnt > 0)
}
}
-return_string_or_null:
return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
}
}
if (SvROK(sv)) {
IV i;
- if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
+ if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg))
return;
i = PTR2IV(SvRV(sv));
sv_unref(sv);
}
if (SvROK(sv)) {
IV i;
- if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
+ if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg))
return;
i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setpvn(sv,s,len);
/* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal()
- * and do what it does outselves here.
+ * and do what it does ourselves here.
* Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags
* set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which
* in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we
- * eleminate quite a few steps than it looks - Yves (explaining patch by gfx)
+ * eliminate quite a few steps than it looks - Yves (explaining patch by gfx)
*/
SvFLAGS(sv) |= flags;
default:
if (SvROK(sv)) {
SvGETMAGIC(sv);
- sv = amagic_deref_call(sv, to_cv_amg);
+ if (SvAMAGIC(sv))
+ sv = amagic_deref_call(sv, to_cv_amg);
/* At this point I'd like to do SPAGAIN, but really I need to
force it upon my callers. Hmmm. This is a mess... */
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
/* tied lvalues should appear to be
- * scalars for backwards compatitbility */
+ * scalars for backwards compatibility */
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
? "SCALAR" : "LVALUE");
case SVt_PVAV: return "ARRAY";
#endif
case 'l':
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
- if (*(q + 1) == 'l') { /* lld, llf */
+ if (*++q == 'l') { /* lld, llf */
intsize = 'q';
- q += 2;
- break;
- }
+ ++q;
+ }
+ else
#endif
- /*FALLTHROUGH*/
+ intsize = 'l';
+ break;
case 'h':
- /*FALLTHROUGH*/
+ if (*++q == 'h') { /* hhd, hhu */
+ intsize = 'c';
+ ++q;
+ }
+ else
+ intsize = 'h';
+ break;
case 'V':
+ case 'z':
+ case 't':
+#if HAS_C99
+ case 'j':
+#endif
intsize = *q++;
break;
}
}
else if (args) {
switch (intsize) {
+ case 'c': iv = (char)va_arg(*args, int); break;
case 'h': iv = (short)va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+ case 'z': iv = va_arg(*args, SSize_t); break;
+ case 't': iv = va_arg(*args, ptrdiff_t); break;
default: iv = va_arg(*args, int); break;
+#if HAS_C99
+ case 'j': iv = va_arg(*args, intmax_t); break;
+#endif
case 'q':
#ifdef HAS_QUAD
iv = va_arg(*args, Quad_t); break;
else {
IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
+ case 'c': iv = (char)tiv; break;
case 'h': iv = (short)tiv; break;
case 'l': iv = (long)tiv; break;
case 'V':
}
else if (args) {
switch (intsize) {
+ case 'c': uv = (unsigned char)va_arg(*args, unsigned); break;
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+ case 'z': uv = va_arg(*args, Size_t); break;
+ case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
+#if HAS_C99
+ case 'j': uv = va_arg(*args, uintmax_t); break;
+#endif
default: uv = va_arg(*args, unsigned); break;
case 'q':
#ifdef HAS_QUAD
else {
UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
switch (intsize) {
+ case 'c': uv = (unsigned char)tuv; break;
case 'h': uv = (unsigned short)tuv; break;
case 'l': uv = (unsigned long)tuv; break;
case 'V':
#else
/*FALLTHROUGH*/
#endif
+ case 'c':
case 'h':
+ case 'z':
+ case 't':
+ case 'j':
goto unknown;
}
i = SvCUR(sv) - origlen;
if (args) {
switch (intsize) {
+ case 'c': *(va_arg(*args, char*)) = i; break;
case 'h': *(va_arg(*args, short*)) = i; break;
default: *(va_arg(*args, int*)) = i; break;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
+ case 'z': *(va_arg(*args, SSize_t*)) = i; break;
+ case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
+#if HAS_C99
+ case 'j': *(va_arg(*args, intmax_t*)) = i; break;
+#endif
case 'q':
#ifdef HAS_QUAD
*(va_arg(*args, Quad_t*)) = i; break;
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
if (SvREADONLY(sstr) && SvFAKE(sstr)) {
/* Not that normal - actually sstr is copy on write.
- But we are a true, independant SV, so: */
+ But we are a true, independent SV, so: */
SvREADONLY_off(dstr);
SvFAKE_off(dstr);
}
++i;
}
if (SvOOK(sstr)) {
- HEK *hvname;
const struct xpvhv_aux * const saux = HvAUX(sstr);
struct xpvhv_aux * const daux = HvAUX(dstr);
/* This flag isn't copied. */
/* SvOOK_on(hv) attacks the IV flags. */
SvFLAGS(dstr) |= SVf_OOK;
- hvname = saux->xhv_name;
if (saux->xhv_name_count) {
- HEK ** const sname = (HEK **)saux->xhv_name;
+ HEK ** const sname = saux->xhv_name_u.xhvnameu_names;
const I32 count
= saux->xhv_name_count < 0
? -saux->xhv_name_count
: saux->xhv_name_count;
HEK **shekp = sname + count;
HEK **dhekp;
- Newxc(daux->xhv_name, count, HEK *, HEK);
- dhekp = (HEK **)daux->xhv_name + count;
+ Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *);
+ dhekp = daux->xhv_name_u.xhvnameu_names + count;
while (shekp-- > sname) {
dhekp--;
*dhekp = hek_dup(*shekp, param);
}
}
- else daux->xhv_name = hek_dup(hvname, param);
+ else {
+ daux->xhv_name_u.xhvnameu_name
+ = hek_dup(saux->xhv_name_u.xhvnameu_name,
+ param);
+ }
daux->xhv_name_count = saux->xhv_name_count;
daux->xhv_riter = saux->xhv_riter;
: 0;
/* Record stashes for possible cloning in Perl_clone(). */
- if (hvname)
+ if (HvNAME(sstr))
av_push(param->stashes, dstr);
}
}
hv_dup(CvSTASH(dstr), param);
if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr))
Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr);
- OP_REFCNT_LOCK;
- if (!CvISXSUB(dstr))
+ if (!CvISXSUB(dstr)) {
+ OP_REFCNT_LOCK;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
- OP_REFCNT_UNLOCK;
- if (CvCONST(dstr) && CvISXSUB(dstr)) {
+ OP_REFCNT_UNLOCK;
+ CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+ } else if (CvCONST(dstr)) {
CvXSUBANY(dstr).any_ptr =
sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param);
}
CvWEAKOUTSIDE(sstr)
? cv_dup( CvOUTSIDE(dstr), param)
: cv_dup_inc(CvOUTSIDE(dstr), param);
- if (!CvISXSUB(dstr))
- CvFILE(dstr) = SAVEPV(CvFILE(dstr));
break;
}
}
ncx->blk_loop.state_u.lazysv.end
= sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
/* We are taking advantage of av_dup_inc and sv_dup_inc
- actually being the same function, and order equivalance of
+ actually being the same function, and order equivalence of
the two unions.
We can assert the later [but only at run time :-(] */
assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
TOPPTR(nss,ix) = pv_dup(c);
break;
case SAVEt_GP: /* scalar reference */
- gv = (const GV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
gp = (GP*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
+ gv = (const GV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
+ PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param);
PL_profiledata = NULL;
PL_restartop = proto_perl->Irestartop;
PL_in_eval = proto_perl->Iin_eval;
PL_delaymagic = proto_perl->Idelaymagic;
- PL_dirty = proto_perl->Idirty;
+ PL_phase = proto_perl->Iphase;
PL_localizing = proto_perl->Ilocalizing;
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
case OP_GVSV:
gv = cGVOPx_gv(obase);
- if (!gv || (match && GvSV(gv) != uninit_sv))
+ if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv))
break;
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
|| (type == OP_PUSHMARK)
+ || (
+ /* @$a and %$a, but not @a or %a */
+ (type == OP_RV2AV || type == OP_RV2HV)
+ && cUNOPx(kid)->op_first
+ && cUNOPx(kid)->op_first->op_type != OP_GV
+ )
)
continue;
}
https://perl5.git.perl.org / perl5.git / blobdiff