/* ============================================================================
-=head1 Allocation and deallocation of SVs.
-
+=for apidoc_section SV Handling
An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
sv, av, hv...) contains type and reference count information, and for
many types, a pointer to the body (struct xrv, xpv, xpviv...), which
/*
-=head1 SV Manipulation Functions
+=for apidoc_section SV Handling
=for apidoc sv_add_arena
U32 arena_size; /* Size of arena to allocate */
};
+#define ALIGNED_TYPE_NAME(name) name##_aligned
+#define ALIGNED_TYPE(name) \
+ typedef union { \
+ name align_me; \
+ NV nv; \
+ IV iv; \
+ } ALIGNED_TYPE_NAME(name);
+
+ALIGNED_TYPE(regexp);
+ALIGNED_TYPE(XPVGV);
+ALIGNED_TYPE(XPVLV);
+ALIGNED_TYPE(XPVAV);
+ALIGNED_TYPE(XPVHV);
+ALIGNED_TYPE(XPVCV);
+ALIGNED_TYPE(XPVFM);
+ALIGNED_TYPE(XPVIO);
+
#define HADNV FALSE
#define NONV TRUE
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- { sizeof(regexp),
+ { sizeof(ALIGNED_TYPE_NAME(regexp)),
sizeof(regexp),
0,
SVt_REGEXP, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(regexp))
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp)))
},
- { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
+ { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) },
- { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
- HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
+ { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
+ HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) },
- { sizeof(XPVAV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVAV)),
copy_length(XPVAV, xav_alloc),
0,
SVt_PVAV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVAV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) },
- { sizeof(XPVHV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVHV)),
copy_length(XPVHV, xhv_max),
0,
SVt_PVHV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVHV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) },
- { sizeof(XPVCV),
+ { sizeof(ALIGNED_TYPE_NAME(XPVCV)),
sizeof(XPVCV),
0,
SVt_PVCV, TRUE, NONV, HASARENA,
- FIT_ARENA(0, sizeof(XPVCV)) },
+ FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) },
- { sizeof(XPVFM),
+ { sizeof(ALIGNED_TYPE_NAME(XPVFM)),
sizeof(XPVFM),
0,
SVt_PVFM, TRUE, NONV, NOARENA,
- FIT_ARENA(20, sizeof(XPVFM)) },
+ FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) },
- { sizeof(XPVIO),
+ { sizeof(ALIGNED_TYPE_NAME(XPVIO)),
sizeof(XPVIO),
0,
SVt_PVIO, TRUE, NONV, HASARENA,
- FIT_ARENA(24, sizeof(XPVIO)) },
+ FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) },
};
#define new_body_allocated(sv_type) \
char *start;
const char *end;
const size_t good_arena_size = Perl_malloc_good_size(arena_size);
-#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
- dVAR;
-#endif
-#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT)
+#if defined(DEBUGGING)
static bool done_sanity_check;
- /* PERL_GLOBAL_STRUCT cannot coexist with global
- * variables like done_sanity_check. */
if (!done_sanity_check) {
unsigned int i = SVt_LAST;
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
}
}
- else {
+ else {
if (isGV_with_GP(sv))
return glob_2number(MUTABLE_GV(sv));
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
#endif /* NV_PRESERVES_UV */
}
- else {
+ else {
if (isGV_with_GP(sv)) {
glob_2number(MUTABLE_GV(sv));
return 0.0;
return RX_WRAPPED(re);
} else {
- const char *const typestr = sv_reftype(referent, 0);
- const STRLEN typelen = strlen(typestr);
+ const char *const typestring = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestring);
UV addr = PTR2UV(referent);
const char *stashname = NULL;
STRLEN stashnamelen = 0; /* hush, gcc */
*--retval = '(';
retval -= typelen;
- memcpy(retval, typestr, typelen);
+ memcpy(retval, typestring, typelen);
if (stashname) {
*--retval = '=';
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set C<*lp>
-to its length. May cause the SV to be downgraded from UTF-8 as a
-side-effect.
+to its length. If the SV is marked as being encoded as UTF-8, it will
+downgrade it to a byte string as a side-effect, if possible. If the SV cannot
+be downgraded, this croaks.
Usually accessed via the C<SvPVbyte> macro.
bytes to be copied. If the C<ptr> argument is NULL the SV will become
undefined. Does not handle 'set' magic. See C<L</sv_setpvn_mg>>.
+The UTF-8 flag is not changed by this function. A terminating NUL byte is
+guaranteed.
+
=cut
*/
C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
+=for apidoc Amnh||SV_CATUTF8
+=for apidoc Amnh||SV_CATBYTES
+
=cut
*/
void
Perl_sv_clear(pTHX_ SV *const orig_sv)
{
- dVAR;
HV *stash;
U32 type;
const struct body_details *sv_type_details;
sv_del_backref(MUTABLE_SV(stash), sv);
goto freescalar;
case SVt_PVHV:
- if (PL_last_swash_hv == (const HV *)sv) {
- PL_last_swash_hv = NULL;
- }
if (HvTOTALKEYS((HV*)sv) > 0) {
const HEK *hek;
/* this statement should match the one at the beginning of
void
Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
{
- dVAR;
PERL_ARGS_ASSERT_SV_FREE2;
else
{
/*The big, slow, and stupid way. */
-#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
- STDCHAR *buf = NULL;
- Newx(buf, 8192, STDCHAR);
- assert(buf);
-#else
STDCHAR buf[8192];
-#endif
screamer2:
if (rslen) {
goto screamer2;
}
-#ifdef USE_HEAP_INSTEAD_OF_STACK
- Safefree(buf);
-#endif
}
if (rspara) { /* have to do this both before and after */
#define newSVpvn_utf8(s, len, u) \
newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
-=for apidoc Amnh||SVf_UTF8
=for apidoc Amnh||SVs_TEMP
=cut
SV *
Perl_sv_2mortal(pTHX_ SV *const sv)
{
- dVAR;
if (!sv)
return sv;
if (SvIMMORTAL(sv))
SV *
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
{
- dVAR;
SV *sv;
bool is_utf8 = FALSE;
const char *const orig_src = src;
Creates a new SV and initializes it with the string formatted like
C<sv_catpvf>.
+=for apidoc newSVpvf_nocontext
+Like C<L</newSVpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
+=for apidoc vnewSVpvf
+Like C<L</newSVpvf>> but but the arguments are an encapsulated argument list.
+
=cut
*/
=for apidoc sv_pvbyten_force
The backend for the C<SvPVbytex_force> macro. Always use the macro
-instead.
+instead. If the SV cannot be downgraded from UTF-8, this croaks.
=cut
*/
=for apidoc sv_isa
Returns a boolean indicating whether the SV is blessed into the specified
-class. This does not check for subtypes; use C<sv_derived_from> to verify
-an inheritance relationship.
+class.
+
+This does not check for subtypes or method overloading. Use C<sv_isa_sv> to
+verify an inheritance relationship in the same way as the C<isa> operator by
+respecting any C<isa()> method overloading; or C<sv_derived_from_sv> to test
+directly on the actual object type.
=cut
*/
Works like C<sv_catpvf> but copies the text into the SV instead of
appending it. Does not handle 'set' magic. See C<L</sv_setpvf_mg>>.
+=for apidoc sv_setpvf_nocontext
+Like C<L</sv_setpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut
*/
Like C<sv_setpvf>, but also handles 'set' magic.
+=for apidoc sv_setpvf_mg_nocontext
+Like C<L</sv_setpvf_mg>>, but does not take a thread context (C<aTHX>)
+parameter, so is used in situations where the caller doesn't already have the
+thread context.
+
=cut
*/
C<L</sv_catpvf_mg>>. If the original SV was UTF-8, the pattern should be
valid UTF-8; if the original SV was bytes, the pattern should be too.
+=for apidoc sv_catpvf_nocontext
+Like C<L</sv_catpvf>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut */
void
Like C<sv_catpvf>, but also handles 'set' magic.
+=for apidoc sv_catpvf_mg_nocontext
+Like C<L</sv_catpvf_mg>> but does not take a thread context (C<aTHX>) parameter,
+so is used in situations where the caller doesn't already have the thread
+context.
+
=cut
*/
/* the asterisk specified a width */
{
int i = 0;
- SV *sv = NULL;
+ SV *width_sv = NULL;
if (args)
i = va_arg(*args, int);
else {
ix = ix ? ix - 1 : svix++;
- sv = (ix < sv_count) ? svargs[ix]
+ width_sv = (ix < sv_count) ? svargs[ix]
: (arg_missing = TRUE, (SV*)NULL);
}
- width = S_sprintf_arg_num_val(aTHX_ args, i, sv, &left);
+ width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left);
}
}
else if (*q == 'v') {
{
int i = 0;
- SV *sv = NULL;
+ SV *width_sv = NULL;
bool neg = FALSE;
if (args)
i = va_arg(*args, int);
else {
ix = ix ? ix - 1 : svix++;
- sv = (ix < sv_count) ? svargs[ix]
+ width_sv = (ix < sv_count) ? svargs[ix]
: (arg_missing = TRUE, (SV*)NULL);
}
- precis = S_sprintf_arg_num_val(aTHX_ args, i, sv, &neg);
+ precis = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &neg);
has_precis = !neg;
/* ignore negative precision */
if (!has_precis)
goto string;
}
- if (vectorize && !strchr("BbDdiOouUXx", c))
+ if (vectorize && !memCHRs("BbDdiOouUXx", c))
goto unknown;
/* get next arg (individual branches do their own va_arg()
* being allowed for %c (ideally we should warn on e.g. '%hc').
* Setting a default intsize, along with a positive
* (which signals unsigned) base, causes, for C-ish use, the
- * va_arg to be interpreted as as unsigned int, when it's
+ * va_arg to be interpreted as an unsigned int, when it's
* actually signed, which will convert -ve values to high +ve
* values. Note that unlike the libc %c, values > 255 will
* convert to high unicode points rather than being truncated
(!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES)
{
- assert(sizeof(ebuf) >= UTF8_MAXBYTES + 1);
+ STATIC_ASSERT_STMT(sizeof(ebuf) >= UTF8_MAXBYTES + 1);
eptr = ebuf;
elen = uvchr_to_utf8((U8*)eptr, uv) - (U8*)ebuf;
is_utf8 = TRUE;
GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(ptr);
- if (!qfmt)
+ if (!quadmath_format_valid(ptr))
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
- qfmt, nv);
+ ptr, nv);
);
if ((IV)elen == -1) {
- if (qfmt != ptr)
- SAVEFREEPV(qfmt);
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", ptr);
}
- if (qfmt != ptr)
- Safefree(qfmt);
}
#elif defined(HAS_LONG_DOUBLE)
WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric,
/* =========================================================================
-=head1 Cloning an interpreter
+=for apidoc_section Embedding and Interpreter Cloning
=cut
static SV *
S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
{
- dVAR;
SV *dstr;
PERL_ARGS_ASSERT_SV_DUP_COMMON;
/* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
- /* XXX what do do with cur_top_env ???? */
+ /* XXX what to do with cur_top_env ???? */
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
ANY *
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
- dVAR;
ANY * const ss = proto_perl->Isavestack;
const I32 max = proto_perl->Isavestack_max + SS_MAXPUSH;
I32 ix = proto_perl->Isavestack_ix;
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = ptr;
break;
+ case SAVEt_HINTS_HH:
+ hv = (const HV *)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ /* FALLTHROUGH */
case SAVEt_HINTS:
ptr = POPPTR(ss,ix);
ptr = cophh_copy((COPHH*)ptr);
TOPPTR(nss,ix) = ptr;
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
- if (i & HINT_LOCALIZE_HH) {
- hv = (const HV *)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
- }
break;
case SAVEt_PADSV_AND_MORTALIZE:
longval = (long)POPLONG(ss,ix);
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
- dVAR;
#ifdef PERL_IMPLICIT_SYS
PERL_ARGS_ASSERT_PERL_CLONE;
PL_origalen = proto_perl->Iorigalen;
PL_sighandlerp = proto_perl->Isighandlerp;
+ PL_sighandler1p = proto_perl->Isighandler1p;
+ PL_sighandler3p = proto_perl->Isighandler3p;
PL_runops = proto_perl->Irunops;
PL_cv_has_eval = proto_perl->Icv_has_eval;
-#ifdef FCRYPT
- PL_cryptseen = proto_perl->Icryptseen;
-#endif
-
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_standard = proto_perl->Icollation_standard;
/* Recursion stopper for PerlIO_find_layer */
PL_in_load_module = proto_perl->Iin_load_module;
- /* sort() routine */
- PL_sort_RealCmp = proto_perl->Isort_RealCmp;
-
/* Not really needed/useful since the reenrant_retint is "volatile",
* but do it for consistency's sake. */
PL_reentrant_retint = proto_perl->Ireentrant_retint;
PL_globhook = proto_perl->Iglobhook;
- /* swatch cache */
- PL_last_swash_hv = NULL; /* reinits on demand */
- PL_last_swash_klen = 0;
- PL_last_swash_key[0]= '\0';
- PL_last_swash_tmps = (U8*)NULL;
- PL_last_swash_slen = 0;
-
PL_srand_called = proto_perl->Isrand_called;
Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
# endif
#endif /* !USE_LOCALE_NUMERIC */
+#ifdef HAS_MBRLEN
+ PL_mbrlen_ps = proto_perl->Imbrlen_ps;
+#endif
+#ifdef HAS_MBRTOWC
+ PL_mbrtowc_ps = proto_perl->Imbrtowc_ps;
+#endif
+#ifdef HAS_WCRTOMB
+ PL_wcrtomb_ps = proto_perl->Iwcrtomb_ps;
+#endif
+
PL_langinfo_buf = NULL;
PL_langinfo_bufsize = 0;
PL_setlocale_buf = NULL;
PL_setlocale_bufsize = 0;
+ /* Unicode inversion lists */
+
+ PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
+ PL_Assigned_invlist = sv_dup_inc(proto_perl->IAssigned_invlist, param);
+ PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
+ PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+ PL_InMultiCharFold = sv_dup_inc(proto_perl->IInMultiCharFold, param);
+ PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+ PL_LB_invlist = sv_dup_inc(proto_perl->ILB_invlist, param);
+ PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
+ PL_SCX_invlist = sv_dup_inc(proto_perl->ISCX_invlist, param);
+ PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
+ PL_in_some_fold = sv_dup_inc(proto_perl->Iin_some_fold, param);
+ PL_utf8_foldclosures = sv_dup_inc(proto_perl->Iutf8_foldclosures, param);
+ PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+ PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
+ PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param);
+ PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param);
+ PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param);
+ PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param);
+ PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
+ for (i = 0; i < POSIX_CC_COUNT; i++) {
+ PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
+ if (i != _CC_CASED && i != _CC_VERTSPACE) {
+ PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
+ }
+ }
+ PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA];
+ PL_Posix_ptrs[_CC_VERTSPACE] = NULL;
+
+ PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
+ PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
+ PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+ PL_utf8_tosimplefold = sv_dup_inc(proto_perl->Iutf8_tosimplefold, param);
+ PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
+ PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
+ PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
+ PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param);
+ PL_CCC_non0_non230 = sv_dup_inc(proto_perl->ICCC_non0_non230, param);
+ PL_Private_Use = sv_dup_inc(proto_perl->IPrivate_Use, param);
+
#if 0
PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param);
#endif
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
- while(av_tindex(param->stashes) != -1) {
+ while(av_count(param->stashes) != 0) {
HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
void
Perl_clone_params_del(CLONE_PARAMS *param)
{
- /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT
- happy: */
+ PerlInterpreter *const was = PERL_GET_THX;
PerlInterpreter *const to = param->new_perl;
dTHXa(to);
- PerlInterpreter *const was = PERL_GET_THX;
PERL_ARGS_ASSERT_CLONE_PARAMS_DEL;
CLONE_PARAMS *
Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to)
{
- dVAR;
/* Need to play this game, as newAV() can call safesysmalloc(), and that
does a dTHX; to get the context from thread local storage.
FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to
void
Perl_init_constants(pTHX)
{
- dVAR;
SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL;
}
/*
-=head1 Unicode Support
+=for apidoc_section Unicode Support
=for apidoc sv_recode_to_utf8
STATIC SV*
S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val)
{
- dVAR;
HE **array;
I32 i;
/*
+=apidoc_section Warning and Dieing
=for apidoc find_uninit_var
Find the name of the undefined variable (if any) that caused the operator
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv,
bool match, const char **desc_p)
{
- dVAR;
SV *sv;
const GV *gv;
const OP *o, *o2, *kid;
negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)),
FUV_SUBSCRIPT_ARRAY);
}
- else {
+ else {
/* index is an expression;
* attempt to find a match within the aggregate */
if (obase->op_type == OP_HELEM) {
: varname(agg_gv, '@', agg_targ,
NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY);
}
- else {
+ else {
/* index is an var */
if (is_hv) {
SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv);
return varname(agg_gv, '@', agg_targ,
NULL, index, FUV_SUBSCRIPT_ARRAY);
}
+ /* look for an element not found */
+ if (!SvMAGICAL(sv)) {
+ SV *index_sv = NULL;
+ if (index_targ) {
+ index_sv = PL_curpad[index_targ];
+ }
+ else if (index_gv) {
+ index_sv = GvSV(index_gv);
+ }
+ if (index_sv && !SvMAGICAL(index_sv) && !SvROK(index_sv)) {
+ if (is_hv) {
+ HE *he = hv_fetch_ent(MUTABLE_HV(sv), index_sv, 0, 0);
+ if (!he) {
+ return varname(agg_gv, '%', agg_targ,
+ index_sv, 0, FUV_SUBSCRIPT_HASH);
+ }
+ }
+ else {
+ SSize_t index = SvIV(index_sv);
+ SV * const * const svp =
+ av_fetch(MUTABLE_AV(sv), index, FALSE);
+ if (!svp) {
+ return varname(agg_gv, '@', agg_targ,
+ NULL, index, FUV_SUBSCRIPT_ARRAY);
+ }
+ }
+ }
+ }
if (match)
break;
return varname(agg_gv,
https://perl5.git.perl.org / perl5.git / blobdiff