STMT_START { \
void ** const r3wt = &PL_body_roots[sv_type]; \
LOCK_SV_MUTEX; \
- xpv = *((void **)(r3wt)) \
- ? *((void **)(r3wt)) : more_bodies(sv_type); \
+ xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
+ ? *((void **)(r3wt)) : more_bodies(sv_type)); \
*(r3wt) = *(void**)(xpv); \
UNLOCK_SV_MUTEX; \
} STMT_END
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
dVAR;
+ PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
}
}
{
- SV *tsv;
+ STRLEN len;
+ char *retval;
+ char *buffer;
MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvs("NULLREF"));
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_PVMG
&& ((SvFLAGS(referent) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
return stringify_regexp(sv, mg, lp);
} else {
const char *const typestr = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
- tsv = sv_newmortal();
if (SvOBJECT(referent)) {
- const char *const name = HvNAME_get(SvSTASH(referent));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr,
- PTR2UV(referent));
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
+ } else {
+ SvUTF8_off(sv);
+ }
+ } else {
+ stashname = "__ANON__";
+ stashnamelen = 8;
+ }
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
- PTR2UV(referent));
+
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
+ }
+ /* retval may not neccesarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
if (sstr == dstr)
return;
+
+ if (SvIS_FREED(dstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+ " to a freed scalar %p", sstr, dstr);
+ }
SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
+ if (SvIS_FREED(sstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
+ dstr);
+ }
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
- if ((int)SvTYPE(sstr) != stype) {
+ if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
glob_assign_glob(dstr, sstr, dtype);
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
+ case PERL_MAGIC_regdata_names:
+ vtable = &PL_vtbl_regdata_names;
+ break;
case PERL_MAGIC_regdatum:
vtable = &PL_vtbl_regdatum;
break;
*/
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf
- " real %"UVf" for %"SVf,
+ Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
+ " real %"UVuf" for %"SVf,
(UV) ulen, (UV) real, (void*)sv);
}
}
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf
- " real %"UVf" for %"SVf,
+ Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
+ " real %"UVuf" for %"SVf,
(UV) boffset, (UV) real_boffset, (void*)sv);
}
}
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf
- " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
+ Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
+ " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
}
}
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf
- " real %"UVf" for %"SVf,
+ Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
+ " real %"UVuf" for %"SVf,
(UV) len, (UV) real_len, (void*)sv);
}
}
pv1 = "";
cur1 = 0;
}
- else
+ else {
+ /* if pv1 and pv2 are the same, second SvPV_const call may
+ * invalidate pv1, so we may need to make a copy */
+ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+ pv1 = SvPV_const(sv1, cur1);
+ sv1 = sv_2mortal(newSVpvn(pv1, cur1));
+ if (SvUTF8(sv2)) SvUTF8_on(sv1);
+ }
pv1 = SvPV_const(sv1, cur1);
+ }
if (!sv2){
pv2 = "";
register SV *sv;
new_SV(sv);
- sv_setpvn(sv,s,len ? len : strlen(s));
+ sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
return sv;
}
=cut
*/
-char *
+const char *
Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
/* The fact that I don't need to downcast to char * everywhere, only in ?:
switch (*q) {
case ' ':
case '+':
- plus = *q++;
+ if (plus == '+' && *q == ' ') /* '+' over ' ' */
+ q++;
+ else
+ plus = *q++;
continue;
case '-':
else
i = (ewix ? ewix <= svmax : svix < svmax)
? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
- precis = (i < 0) ? 0 : i;
+ precis = i;
+ has_precis = !(i < 0);
}
else {
precis = 0;
while (isDIGIT(*q))
precis = precis * 10 + (*q++ - '0');
+ has_precis = TRUE;
}
- has_precis = TRUE;
}
/* SIZE */
else {
eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv)) {
+ I32 old_precis = precis;
if (has_precis && precis < elen) {
I32 p = precis;
sv_pos_u2b(argsv, &p, 0); /* sticks at end */
precis = p;
}
if (width) { /* fudge width (can't fudge elen) */
- width += elen - sv_len_utf8(argsv);
+ if (has_precis && precis < elen)
+ width += precis - old_precis;
+ else
+ width += elen - sv_len_utf8(argsv);
}
is_utf8 = TRUE;
}
switch (base) {
unsigned dig;
case 16:
- p = (char*)((c == 'X')
- ? "0123456789ABCDEF" : "0123456789abcdef");
+ p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
do {
dig = uv & 15;
*--ptr = p[dig];
zeros = precis - elen;
else if (precis == 0 && elen == 1 && *eptr == '0')
elen = 0;
+
+ /* a precision nullifies the 0 flag. */
+ if (fill == '0')
+ fill = ' ';
}
}
break;
REGEXP *
Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
{
- dVAR;
- REGEXP *ret;
- int i, len, npar;
- struct reg_substr_datum *s;
-
- if (!r)
- return (REGEXP *)NULL;
-
- if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
- return ret;
-
- len = r->offsets[0];
- npar = r->nparens+1;
-
- Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
- Copy(r->program, ret->program, len+1, regnode);
-
- Newx(ret->startp, npar, I32);
- Copy(r->startp, ret->startp, npar, I32);
- Newx(ret->endp, npar, I32);
- Copy(r->startp, ret->startp, npar, I32);
-
- Newx(ret->substrs, 1, struct reg_substr_data);
- for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
- s->min_offset = r->substrs->data[i].min_offset;
- s->max_offset = r->substrs->data[i].max_offset;
- s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
- s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
- }
-
- ret->regstclass = NULL;
- if (r->data) {
- struct reg_data *d;
- const int count = r->data->count;
- int i;
-
- Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
- char, struct reg_data);
- Newx(d->what, count, U8);
-
- d->count = count;
- for (i = 0; i < count; i++) {
- d->what[i] = r->data->what[i];
- switch (d->what[i]) {
- /* legal options are one of: sfpont
- see also regcomp.h and pregfree() */
- case 's':
- d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
- break;
- case 'p':
- d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
- break;
- case 'f':
- /* This is cheating. */
- Newx(d->data[i], 1, struct regnode_charclass_class);
- StructCopy(r->data->data[i], d->data[i],
- struct regnode_charclass_class);
- ret->regstclass = (regnode*)d->data[i];
- break;
- case 'o':
- /* Compiled op trees are readonly, and can thus be
- shared without duplication. */
- OP_REFCNT_LOCK;
- d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
- OP_REFCNT_UNLOCK;
- break;
- case 'n':
- d->data[i] = r->data->data[i];
- break;
- case 't':
- d->data[i] = r->data->data[i];
- OP_REFCNT_LOCK;
- ((reg_trie_data*)d->data[i])->refcount++;
- OP_REFCNT_UNLOCK;
- break;
- case 'T':
- d->data[i] = r->data->data[i];
- OP_REFCNT_LOCK;
- ((reg_ac_data*)d->data[i])->refcount++;
- OP_REFCNT_UNLOCK;
- /* Trie stclasses are readonly and can thus be shared
- * without duplication. We free the stclass in pregfree
- * when the corresponding reg_ac_data struct is freed.
- */
- ret->regstclass= r->regstclass;
- break;
- default:
- Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
- }
- }
-
- ret->data = d;
- }
- else
- ret->data = NULL;
-
- Newx(ret->offsets, 2*len+1, U32);
- Copy(r->offsets, ret->offsets, 2*len+1, U32);
-
- ret->precomp = SAVEPVN(r->precomp, r->prelen);
- ret->refcnt = r->refcnt;
- ret->minlen = r->minlen;
- ret->prelen = r->prelen;
- ret->nparens = r->nparens;
- ret->lastparen = r->lastparen;
- ret->lastcloseparen = r->lastcloseparen;
- ret->reganch = r->reganch;
-
- ret->sublen = r->sublen;
-
- if (RX_MATCH_COPIED(ret))
- ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
- else
- ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
- ret->saved_copy = NULL;
-#endif
-
- ptr_table_store(PL_ptr_table, r, ret);
- return ret;
+ return CALLREGDUPE(r,param);
}
/* duplicate a file handle */
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
- ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
- ncx->blk_loop.next_op = cx->blk_loop.next_op;
- ncx->blk_loop.last_op = cx->blk_loop.last_op;
+ ncx->blk_loop.my_op = cx->blk_loop.my_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
: gv_dup((GV*)cx->blk_loop.iterdata, param));
long longval;
GP *gp;
IV iv;
+ I32 i;
char *c = NULL;
void (*dptr) (void*);
void (*dxptr) (pTHX_ void*);
Newxz(nss, max, ANY);
while (ix > 0) {
- I32 i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
- switch (i) {
+ const I32 type = POPINT(ss,ix);
+ TOPINT(nss,ix) = type;
+ switch (type) {
case SAVEt_ITEM: /* normal string */
case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
break;
case SAVEt_HV: /* hash reference */
case SAVEt_AV: /* array reference */
- sv = POPPTR(ss,ix);
+ sv = (SV*) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- i = POPINT(ss,ix);
+ POPINT(ss,ix);
TOPINT(nss,ix) = i;
break;
case SAVEt_IV: /* IV reference */
new_state->re_state_regeol
= pv_dup(old_state->re_state_regeol);
new_state->re_state_regstartp
- = any_dup(old_state->re_state_regstartp, proto_perl);
+ = (I32*) any_dup(old_state->re_state_regstartp, proto_perl);
new_state->re_state_regendp
- = any_dup(old_state->re_state_regendp, proto_perl);
+ = (I32*) any_dup(old_state->re_state_regendp, proto_perl);
new_state->re_state_reglastparen
- = any_dup(old_state->re_state_reglastparen, proto_perl);
+ = (U32*) any_dup(old_state->re_state_reglastparen,
+ proto_perl);
new_state->re_state_reglastcloseparen
- = any_dup(old_state->re_state_reglastcloseparen,
+ = (U32*)any_dup(old_state->re_state_reglastcloseparen,
proto_perl);
/* XXX This just has to be broken. The old save_re_context
code did SAVEGENERICPV(PL_reg_start_tmp);
= sv_dup(old_state->re_state_nrs, param);
#endif
new_state->re_state_reg_magic
- = any_dup(old_state->re_state_reg_magic, proto_perl);
+ = (MAGIC*) any_dup(old_state->re_state_reg_magic,
+ proto_perl);
new_state->re_state_reg_oldcurpm
- = any_dup(old_state->re_state_reg_oldcurpm, proto_perl);
+ = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
+ proto_perl);
new_state->re_state_reg_curpm
- = any_dup(old_state->re_state_reg_curpm, proto_perl);
+ = (PMOP*) any_dup(old_state->re_state_reg_curpm,
+ proto_perl);
new_state->re_state_reg_oldsaved
= pv_dup(old_state->re_state_reg_oldsaved);
new_state->re_state_reg_poscache
sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
+ /* RE engine related */
+ Zero(&PL_reg_state, 1, struct re_save_state);
+ PL_reginterp_cnt = 0;
+ PL_regmatch_slab = NULL;
+
/* Clone the regex array */
PL_regex_padav = newAV();
{
PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
+ PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param);
+ PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
- PL_uudmap['M'] = 0; /* reinits on demand */
+ PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */
PL_bitcount = NULL; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- /* RE engine - function pointers */
- PL_regcompp = proto_perl->Tregcompp;
- PL_regexecp = proto_perl->Tregexecp;
- PL_regint_start = proto_perl->Tregint_start;
- PL_regint_string = proto_perl->Tregint_string;
- PL_regfree = proto_perl->Tregfree;
- Zero(&PL_reg_state, 1, struct re_save_state);
- PL_reginterp_cnt = 0;
- PL_regmatch_slab = NULL;
+
/* Pluggable optimizer */
PL_peepp = proto_perl->Tpeepp;
https://perl5.git.perl.org / perl5.git / blobdiff