(SV *)Perl_die(aTHX_
S_no_symref_sv,
sv,
- (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""),
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
"a symbol"
);
if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
if (PL_op->op_private & HINT_STRICT_REFS) {
if (SvOK(sv))
- Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ Perl_die(aTHX_ S_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
else
Perl_die(aTHX_ PL_no_usym, what);
}
/* (But not in defined().) */
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
- if (cv) {
- if (CvCLONE(cv))
- cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
- }
+ if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
cv = MUTABLE_CV(gv);
}
GV *gv;
SV *ret = &PL_sv_undef;
+ if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
{
dVAR; dSP; dPOPss;
register unsigned char *s;
- char *sfirst_raw;
STRLEN len;
- MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_study) : NULL;
- U8 quanta;
- STRLEN size;
-
- if (mg && SvSCREAM(sv))
- RETPUSHYES;
s = (unsigned char*)(SvPV(sv, len));
if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
- /* No point in studying a zero length string, and not safe to study
- anything that doesn't appear to be a simple scalar (and hence might
- change between now and when the regexp engine runs without our set
- magic ever running) such as a reference to an object with overloaded
- stringification. Also refuse to study an FBM scalar, as this gives
- more flexibility in SV flag usage. No real-world code would ever
- end up studying an FBM scalar, so this isn't a real pessimisation.
- Endemic use of I32 in Perl_screaminstr makes it hard to safely push
- the study length limit from I32_MAX to U32_MAX - 1.
- */
+ /* Historically, study was skipped in these cases. */
RETPUSHNO;
}
/* Make study a no-op. It's no longer useful and its existence
- complicates matters elsewhere. This is a low-impact band-aid.
- The relevant code will be neatly removed in a future release. */
- RETPUSHYES;
-
- if (len < 0xFF) {
- quanta = 1;
- } else if (len < 0xFFFF) {
- quanta = 2;
- } else
- quanta = 4;
-
- size = (256 + len) * quanta;
- sfirst_raw = (char *)safemalloc(size);
-
- if (!sfirst_raw)
- DIE(aTHX_ "do_study: out of memory");
-
- SvSCREAM_on(sv);
- if (!mg)
- mg = sv_magicext(sv, NULL, PERL_MAGIC_study, &PL_vtbl_regexp, NULL, 0);
- mg->mg_ptr = sfirst_raw;
- mg->mg_len = size;
- mg->mg_private = quanta;
-
- memset(sfirst_raw, ~0, 256 * quanta);
-
- /* The assumption here is that most studied strings are fairly short, hence
- the pain of the extra code is worth it, given the memory savings.
- 80 character string, 336 bytes as U8, down from 1344 as U32
- 800 character string, 2112 bytes as U16, down from 4224 as U32
- */
-
- if (quanta == 1) {
- U8 *const sfirst = (U8 *)sfirst_raw;
- U8 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- } else if (quanta == 2) {
- U16 *const sfirst = (U16 *)sfirst_raw;
- U16 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- } else {
- U32 *const sfirst = (U32 *)sfirst_raw;
- U32 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- }
-
+ complicates matters elsewhere. */
RETPUSHYES;
}
/* For integer to integer power, we do the calculation by hand wherever
we're sure it is safe; otherwise we call pow() and try to convert to
integer afterwards. */
- {
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
UV power;
bool baseuok;
UV baseuv;
RETURN;
}
}
- }
- }
}
float_it:
#endif
svr = TOPs;
svl = TOPm1s;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
bool auvok = SvUOK(svl);
bool buvok = SvUOK(svr);
const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
#endif
#ifdef PERL_TRY_UV_DIVIDE
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
bool left_non_neg = SvUOK(svl);
bool right_non_neg = SvUOK(svr);
UV left;
RETURN;
} /* tried integer divide but it was not an integer result */
} /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
- } /* left wasn't SvIOK */
- } /* right wasn't SvIOK */
+ } /* one operand wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
NV right = SvNV_nomg(svr);
NV dleft = 0.0;
SV * const svr = TOPs;
SV * const svl = TOPm1s;
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
right_neg = !SvUOK(svr);
if (!right_neg) {
right = SvUVX(svr);
/* At this point use_double is only true if right is out of range for
a UV. In range NV has been rounded down to nearest UV and
use_double false. */
- SvIV_please_nomg(svl);
- if (!use_double && SvIOK(svl)) {
- if (SvIOK(svl)) {
+ if (!use_double && SvIV_please_nomg(svl)) {
left_neg = !SvUOK(svl);
if (!left_neg) {
left = SvUVX(svl);
left = -aiv;
}
}
- }
}
else {
dleft = SvNV_nomg(svl);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(right);
/* Fortunately it seems NaN isn't IOK */
- if (SvIOK(right)) {
- SvIV_please_nomg(left);
- if (SvIOK(left)) {
+ if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
if (!SvUOK(left)) {
const IV leftiv = SvIVX(left);
if (!SvUOK(right)) {
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- /* NOTREACHED */
- }
+ assert(0); /* NOTREACHED */
}
#endif
{
tryAMAGICun_MG(neg_amg, AMGf_numeric);
{
SV * const sv = TOPs;
- const int flags = SvFLAGS(sv);
-
- if( !SvNIOK( sv ) && looks_like_number( sv ) ){
- SvIV_please( sv );
- }
- if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
- /* It's publicly an integer, or privately an integer-not-float */
+ if (SvIOK(sv) || (SvGMAGICAL(sv) && SvIOKp(sv))) {
+ /* It's publicly an integer */
oops_its_an_int:
if (SvIsUV(sv)) {
if (SvIVX(sv) == IV_MIN) {
}
#endif
}
- if (SvNIOKp(sv))
+ if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
SETn(-SvNV_nomg(sv));
else if (SvPOKp(sv)) {
STRLEN len;
sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
- else if (*s == '+' || *s == '-') {
+ else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
sv_setsv_nomg(TARG, sv);
*SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
}
- else if (DO_UTF8(sv)) {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
- goto oops_its_an_int;
- if (SvNOK(sv))
- sv_setnv(TARG, -SvNV_nomg(sv));
- else {
- sv_setpvs(TARG, "-");
- sv_catsv(TARG, sv);
- }
- }
- else {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
+ else if (SvIV_please_nomg(sv))
goto oops_its_an_int;
+ else
sv_setnv(TARG, -SvNV_nomg(sv));
- }
SETTARG;
}
else
PP(pp_srand)
{
dVAR; dSP; dTARGET;
- const UV anum = (MAXARG < 1 || (!TOPs && !POPs)) ? seed() : POPu;
+ UV anum;
+
+ if (MAXARG >= 1 && (TOPs || POPs)) {
+ SV *top;
+ char *pv;
+ STRLEN len;
+ int flags;
+
+ top = POPs;
+ pv = SvPV(top, len);
+ flags = grok_number(pv, len, &anum);
+
+ if (!(flags & IS_NUMBER_IN_UV)) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+ "Integer overflow in srand");
+ anum = UV_MAX;
+ }
+ }
+ else {
+ anum = seed();
+ }
+
(void)seedDrand01((Rand_seed_t)anum);
PL_srand_called = TRUE;
if (anum)
dVAR; dSP; dTARGET;
char *tmps;
UV value;
+ SV *top = POPs;
- if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
+ SvGETMAGIC(top);
+ if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
+ && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
||
- (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
- if (IN_BYTES) {
- value = POPu; /* chr(-1) eq chr(0xff), etc. */
- } else {
- (void) POPs; /* Ignore the argument value. */
+ ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
+ && SvNV_nomg(top) < 0.0))) {
+ if (ckWARN(WARN_UTF8)) {
+ if (SvGMAGICAL(top)) {
+ SV *top2 = sv_newmortal();
+ sv_setsv_nomg(top2, top);
+ top = top2;
+ }
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "Invalid negative number (%"SVf") in chr", top);
+ }
value = UNICODE_REPLACEMENT;
- }
} else {
- value = POPu;
+ value = SvUV_nomg(top);
}
SvUPGRADE(TARG,SVt_PV);
const I32 gimme = GIMME_V;
const MAGIC *mg;
HV *stash;
-
- if (PL_op->op_private & OPpSLICE) {
- dMARK; dORIGMARK;
- SV * const osv = POPs;
- const bool tied = SvRMAGICAL(osv)
+ const bool sliced = !!(PL_op->op_private & OPpSLICE);
+ SV *unsliced_keysv = sliced ? NULL : POPs;
+ SV * const osv = POPs;
+ register SV **mark =
+ sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
+ dORIGMARK;
+ const bool tied = SvRMAGICAL(osv)
&& mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
- const U32 type = SvTYPE(osv);
- if (type == SVt_PVHV) { /* hash element */
+ const bool can_preserve = SvCANEXISTDELETE(osv);
+ const U32 type = SvTYPE(osv);
+ SV ** const end = sliced ? SP : &unsliced_keysv;
+
+ if (type == SVt_PVHV) { /* hash element */
HV * const hv = MUTABLE_HV(osv);
- while (++MARK <= SP) {
+ while (++MARK <= end) {
SV * const keysv = *MARK;
SV *sv = NULL;
bool preeminent = TRUE;
SvREFCNT_inc_simple_void(sv); /* De-mortalize */
}
if (preeminent) {
+ if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
if (tied) {
*MARK = sv_mortalcopy(sv);
*MARK = &PL_sv_undef;
}
}
- }
- else if (type == SVt_PVAV) { /* array element */
+ }
+ else if (type == SVt_PVAV) { /* array element */
if (PL_op->op_flags & OPf_SPECIAL) {
AV * const av = MUTABLE_AV(osv);
- while (++MARK <= SP) {
+ while (++MARK <= end) {
I32 idx = SvIV(*MARK);
SV *sv = NULL;
bool preeminent = TRUE;
}
}
}
- }
- else
+ else
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
+ }
+ else
DIE(aTHX_ "Not a HASH reference");
+ if (sliced) {
if (gimme == G_VOID)
SP = ORIGMARK;
else if (gimme == G_SCALAR) {
SP = MARK;
}
}
- else {
- SV * const keysv = POPs;
- SV * const osv = POPs;
- const bool tied = SvRMAGICAL(osv)
- && mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
- const U32 type = SvTYPE(osv);
- SV *sv = NULL;
- if (type == SVt_PVHV) {
- HV * const hv = MUTABLE_HV(osv);
- bool preeminent = TRUE;
- if (can_preserve)
- preeminent = hv_exists_ent(hv, keysv, 0);
- if (tied) {
- HE *he = hv_fetch_ent(hv, keysv, 1, 0);
- if (he)
- sv = HeVAL(he);
- else
- preeminent = FALSE;
- }
- else {
- sv = hv_delete_ent(hv, keysv, 0, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
- }
- if (preeminent) {
- save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
- if (tied) {
- SV *nsv = sv_mortalcopy(sv);
- mg_clear(sv);
- sv = nsv;
- }
- }
- else
- SAVEHDELETE(hv, keysv);
- }
- else if (type == SVt_PVAV) {
- if (PL_op->op_flags & OPf_SPECIAL) {
- AV * const av = MUTABLE_AV(osv);
- I32 idx = SvIV(keysv);
- bool preeminent = TRUE;
- if (can_preserve)
- preeminent = av_exists(av, idx);
- if (tied) {
- SV **svp = av_fetch(av, idx, 1);
- if (svp)
- sv = *svp;
- else
- preeminent = FALSE;
- }
- else {
- sv = av_delete(av, idx, 0);
- SvREFCNT_inc_simple_void(sv); /* De-mortalize */
- }
- if (preeminent) {
- save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
- if (tied) {
- SV *nsv = sv_mortalcopy(sv);
- mg_clear(sv);
- sv = nsv;
- }
- }
- else
- SAVEADELETE(av, idx);
- }
- else
- DIE(aTHX_ "panic: avhv_delete no longer supported");
- }
- else
- DIE(aTHX_ "Not a HASH reference");
- if (!sv)
- sv = &PL_sv_undef;
- if (gimme != G_VOID)
- PUSHs(sv);
- }
+ else if (gimme != G_VOID)
+ PUSHs(unsliced_keysv);
RETURN;
}
MAGIC *mg;
HV *stash;
- if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ if (SvCANEXISTDELETE(hv))
can_preserve = TRUE;
}
I32 rex_return;
PUTBACK;
rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
- sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
+ sv, NULL, 0);
SPAGAIN;
if (rex_return == 0)
break;
oldsi->si_cxix = oldcxix;
}
else cv = find_runcv(NULL);
- XPUSHs(CvUNIQUE(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
+ XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
RETURN;
}
https://perl5.git.perl.org / perl5.git / blobdiff