/* For left shifts, perl 5 has chosen to treat the value as unsigned for
* the * purposes of shifting, then cast back to signed. This is very
- * different from perl 6:
+ * different from Raku:
*
- * $ perl6 -e 'say -2 +< 5'
+ * $ raku -e 'say -2 +< 5'
* -64
*
* $ ./perl -le 'print -2 << 5'
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
tryAMAGICbin_MG(lt_amg, AMGf_numeric);
right = POPs;
left = TOPs;
+ flags_and = SvFLAGS(left) & SvFLAGS(right);
+ flags_or = SvFLAGS(left) | SvFLAGS(right);
+
SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) < SvIVX(right))
- : (do_ncmp(left, right) == -1)
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) < SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) < SvNVX(right))
+ : (do_ncmp(left, right) == -1)
));
RETURN;
}
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
tryAMAGICbin_MG(gt_amg, AMGf_numeric);
right = POPs;
left = TOPs;
+ flags_and = SvFLAGS(left) & SvFLAGS(right);
+ flags_or = SvFLAGS(left) | SvFLAGS(right);
+
SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) > SvIVX(right))
- : (do_ncmp(left, right) == 1)
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) > SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) > SvNVX(right))
+ : (do_ncmp(left, right) == 1)
));
RETURN;
}
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
tryAMAGICbin_MG(le_amg, AMGf_numeric);
right = POPs;
left = TOPs;
+ flags_and = SvFLAGS(left) & SvFLAGS(right);
+ flags_or = SvFLAGS(left) | SvFLAGS(right);
+
SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) <= SvIVX(right))
- : (do_ncmp(left, right) <= 0)
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) <= SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) <= SvNVX(right))
+ : (do_ncmp(left, right) <= 0)
));
RETURN;
}
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
tryAMAGICbin_MG(ge_amg, AMGf_numeric);
right = POPs;
left = TOPs;
+ flags_and = SvFLAGS(left) & SvFLAGS(right);
+ flags_or = SvFLAGS(left) | SvFLAGS(right);
+
SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) >= SvIVX(right))
- : ( (do_ncmp(left, right) & 2) == 0)
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) >= SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) >= SvNVX(right))
+ : ( (do_ncmp(left, right) & 2) == 0)
));
RETURN;
}
{
dSP;
SV *left, *right;
+ U32 flags_and, flags_or;
tryAMAGICbin_MG(ne_amg, AMGf_numeric);
right = POPs;
left = TOPs;
+ flags_and = SvFLAGS(left) & SvFLAGS(right);
+ flags_or = SvFLAGS(left) | SvFLAGS(right);
+
SETs(boolSV(
- (SvIOK_notUV(left) && SvIOK_notUV(right))
- ? (SvIVX(left) != SvIVX(right))
- : (do_ncmp(left, right) != 0)
+ ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+ ? (SvIVX(left) != SvIVX(right))
+ : (flags_and & SVf_NOK)
+ ? (SvNVX(left) != SvNVX(right))
+ : (do_ncmp(left, right) != 0)
));
RETURN;
}
PP(pp_i_modulo)
{
- /* This is the vanilla old i_modulo. */
dSP; dATARGET;
tryAMAGICbin_MG(modulo_amg, AMGf_assign);
{
}
}
-#if defined(__GLIBC__) && IVSIZE == 8 \
- && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))
-
-PP(pp_i_modulo_glibc_bugfix)
-{
- /* This is the i_modulo with the workaround for the _moddi3 bug
- * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
- * See below for pp_i_modulo. */
- dSP; dATARGET;
- tryAMAGICbin_MG(modulo_amg, AMGf_assign);
- {
- dPOPTOPiirl_nomg;
- if (!right)
- DIE(aTHX_ "Illegal modulus zero");
- /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
- if (right == -1)
- SETi( 0 );
- else
- SETi( left % PERL_ABS(right) );
- RETURN;
- }
-}
-#endif
-
PP(pp_i_add)
{
dSP; dATARGET;
if (*tmps == '0')
tmps++, len--;
if (isALPHA_FOLD_EQ(*tmps, 'x')) {
+ tmps++, len--;
+ flags |= PERL_SCAN_DISALLOW_PREFIX;
hex:
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
}
- else if (isALPHA_FOLD_EQ(*tmps, 'b'))
+ else if (isALPHA_FOLD_EQ(*tmps, 'b')) {
+ tmps++, len--;
+ flags |= PERL_SCAN_DISALLOW_PREFIX;
result_uv = grok_bin (tmps, &len, &flags, &result_nv);
+ }
else
result_uv = grok_oct (tmps, &len, &flags, &result_nv);
push_result:
/* OPpTRUEBOOL indicates an '== -1' has been optimised away */
if (PL_op->op_private & OPpTRUEBOOL) {
- PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
- ? &PL_sv_yes : &PL_sv_no);
- if (PL_op->op_private & OPpTARGET_MY)
+ SV *result = ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG))
+ ? &PL_sv_yes : &PL_sv_no;
+ if (PL_op->op_private & OPpTARGET_MY) {
/* $lex = (index() == -1) */
- sv_setsv(TARG, TOPs);
+ sv_setsv_mg(TARG, result);
+ PUSHs(TARG);
+ }
+ else {
+ PUSHs(result);
+ }
}
else
PUSHi(retval);
sv_utf8_downgrade(tsv, FALSE);
tmps = SvPV_const(tsv, len);
}
-# ifdef USE_ITHREADS
-# ifdef HAS_CRYPT_R
+# ifdef USE_ITHREADS
+# ifdef HAS_CRYPT_R
if (!PL_reentrant_buffer->_crypt_struct_buffer) {
/* This should be threadsafe because in ithreads there is only
* one thread per interpreter. If this would not be true,
* we would need a mutex to protect this malloc. */
PL_reentrant_buffer->_crypt_struct_buffer =
(struct crypt_data *)safemalloc(sizeof(struct crypt_data));
-#if defined(__GLIBC__) || defined(__EMX__)
+# if defined(__GLIBC__) || defined(__EMX__)
if (PL_reentrant_buffer->_crypt_struct_buffer) {
PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
-#if (defined(__GLIBC__) && __GLIBC__ == 2) && \
- (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4)
- /* work around glibc-2.2.5 bug, has been fixed at some
- * time in glibc-2.3.X */
- PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
-#endif
}
-#endif
+# endif
}
-# endif /* HAS_CRYPT_R */
-# endif /* USE_ITHREADS */
-# ifdef FCRYPT
- sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
-# else
+# endif /* HAS_CRYPT_R */
+# endif /* USE_ITHREADS */
+
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
-# endif
+
SvUTF8_off(TARG);
SETTARG;
RETURN;
PP(pp_uc)
{
- dVAR;
dSP;
SV *source = TOPs;
STRLEN len;
IV *iterp = Perl_av_iter_p(aTHX_ array);
const IV current = (*iterp)++;
- if (current > av_tindex(array)) {
+ if (current > av_top_index(array)) {
*iterp = 0;
if (gimme == G_SCALAR)
RETPUSHUNDEF;
if (gimme == G_SCALAR) {
dTARGET;
- PUSHi(av_tindex(array) + 1);
+ PUSHi(av_count(array));
}
else if (gimme == G_ARRAY) {
if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
"Can't modify keys on array in list assignment");
}
{
- IV n = Perl_av_len(aTHX_ array);
+ IV n = av_top_index(array);
IV i;
EXTEND(SP, n + 1);
const MAGIC *mg;
bool can_preserve = SvCANEXISTDELETE(av);
- for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
+ for (i = 0, j = av_top_index(av); i < j; ++i, --j) {
SV *begin, *end;
if (can_preserve) {
sv_setsv(TARG, DEFSV);
XPUSHs(TARG);
}
+ SvSETMAGIC(TARG); /* remove any utf8 length magic */
up = SvPV_force(TARG, len);
if (len > 1) {
/* handle @ary = split(...) optimisation */
if (PL_op->op_private & OPpSPLIT_ASSIGN) {
+ realarray = 1;
if (!(PL_op->op_flags & OPf_STACKED)) {
if (PL_op->op_private & OPpSPLIT_LEX) {
if (PL_op->op_private & OPpLVAL_INTRO)
oldsave = PL_savestack_ix;
}
- realarray = 1;
- PUTBACK;
- av_extend(ary,0);
- (void)sv_2mortal(SvREFCNT_inc_simple_NN(sv));
- av_clear(ary);
- SPAGAIN;
+ /* Some defence against stack-not-refcounted bugs */
+ (void)sv_2mortal(SvREFCNT_inc_simple_NN(ary));
+
if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
PUSHMARK(SP);
XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
- }
- else {
- if (!AvREAL(ary)) {
- I32 i;
- AvREAL_on(ary);
- AvREIFY_off(ary);
- for (i = AvFILLp(ary); i >= 0; i--)
- AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
- }
- /* temporarily switch stacks */
- SAVESWITCHSTACK(PL_curstack, ary);
+ } else {
make_mortal = 0;
}
}
}
}
else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
- /*
- Pre-extend the stack, either the number of bytes or
- characters in the string or a limited amount, triggered by:
-
- my ($x, $y) = split //, $str;
- or
- split //, $str, $i;
- */
- if (!gimme_scalar) {
- const IV items = limit - 1;
- /* setting it to -1 will trigger a panic in EXTEND() */
- const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
- if (items >=0 && items < sslen)
- EXTEND(SP, items);
- else
- EXTEND(SP, sslen);
- }
-
- if (do_utf8) {
- while (--limit) {
- /* keep track of how many bytes we skip over */
- m = s;
- s += UTF8SKIP(s);
- if (gimme_scalar) {
- iters++;
- if (s-m == 0)
- trailing_empty++;
- else
- trailing_empty = 0;
- } else {
- dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
-
- PUSHs(dstr);
- }
-
- if (s >= strend)
- break;
+ /* This case boils down to deciding which is the smaller of:
+ * limit - effectively a number of characters
+ * slen - which already contains the number of characters in s
+ *
+ * The resulting number is the number of iters (for gimme_scalar)
+ * or the number of SVs to create (!gimme_scalar). */
+
+ /* setting it to -1 will trigger a panic in EXTEND() */
+ const SSize_t sslen = slen > SSize_t_MAX ? -1 : (SSize_t)slen;
+ const IV items = limit - 1;
+ if (sslen < items || items < 0) {
+ iters = slen -1;
+ limit = slen + 1;
+ /* Note: The same result is returned if the following block
+ * is removed, because of the "keep field after final delim?"
+ * adjustment, but having the following makes the "correct"
+ * behaviour more apparent. */
+ if (gimme_scalar) {
+ s = strend;
+ iters++;
}
} else {
- while (--limit) {
- if (gimme_scalar) {
- iters++;
- } else {
- dstr = newSVpvn(s, 1);
-
-
- if (make_mortal)
- sv_2mortal(dstr);
-
- PUSHs(dstr);
- }
-
- s++;
-
- if (s >= strend)
- break;
+ iters = items;
+ }
+ if (!gimme_scalar) {
+ /*
+ Pre-extend the stack, either the number of bytes or
+ characters in the string or a limited amount, triggered by:
+ my ($x, $y) = split //, $str;
+ or
+ split //, $str, $i;
+ */
+ EXTEND(SP, limit);
+ if (do_utf8) {
+ while (--limit) {
+ m = s;
+ s += UTF8SKIP(s);
+ dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
+ PUSHs(dstr);
+ }
+ } else {
+ while (--limit) {
+ dstr = newSVpvn_flags(s, 1, make_mortal);
+ PUSHs(dstr);
+ s++;
+ }
}
}
}
}
PUTBACK;
- LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
+ LEAVE_SCOPE(oldsave);
SPAGAIN;
if (realarray) {
- if (!mg) {
- if (SvSMAGICAL(ary)) {
- PUTBACK;
+ if (!mg) {
+ PUTBACK;
+ if(AvREAL(ary)) {
+ if (av_count(ary) > 0)
+ av_clear(ary);
+ } else {
+ AvREAL_on(ary);
+ AvREIFY_off(ary);
+
+ if (AvMAX(ary) > -1) {
+ /* don't free mere refs */
+ Zero(AvARRAY(ary), AvMAX(ary), SV*);
+ }
+ }
+ if(AvMAX(ary) < iters)
+ av_extend(ary,iters);
+ SPAGAIN;
+
+ /* Need to copy the SV*s from the stack into ary */
+ Copy(SP + 1 - iters, AvARRAY(ary), iters, SV*);
+ AvFILLp(ary) = iters - 1;
+
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
mg_set(MUTABLE_SV(ary));
SPAGAIN;
- }
- if (gimme == G_ARRAY) {
- EXTEND(SP, iters);
- Copy(AvARRAY(ary), SP + 1, iters, SV*);
- SP += iters;
- RETURN;
- }
+ }
+
+ if (gimme != G_ARRAY) {
+ /* SP points to the final SV* pushed to the stack. But the SV* */
+ /* are not going to be used from the stack. Point SP to below */
+ /* the first of these SV*. */
+ SP -= iters;
+ PUTBACK;
+ }
}
else {
- PUTBACK;
- ENTER_with_name("call_PUSH");
- call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
- LEAVE_with_name("call_PUSH");
- SPAGAIN;
+ PUTBACK;
+ av_extend(ary,iters);
+ av_clear(ary);
+
+ ENTER_with_name("call_PUSH");
+ call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
+ LEAVE_with_name("call_PUSH");
+ SPAGAIN;
+
if (gimme == G_ARRAY) {
SSize_t i;
/* EXTEND should not be needed - we just popped them */
- EXTEND(SP, iters);
+ EXTEND_SKIP(SP, iters);
for (i=0; i < iters; i++) {
SV **svp = av_fetch(ary, i, FALSE);
PUSHs((svp) ? *svp : &PL_sv_undef);
}
}
}
- else {
- if (gimme == G_ARRAY)
- RETURN;
- }
- GETTARGET;
- XPUSHi(iters);
+ if (gimme != G_ARRAY) {
+ GETTARGET;
+ XPUSHi(iters);
+ }
+
RETURN;
}
Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
if we get here for a custom op then that means that the custom op didn't
have an implementation. Given that OP_NAME() looks up the custom op
- by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
- registers &PL_unimplemented_op as the address of their custom op.
+ by its op_ppaddr, likely it will return NULL, unless someone (unhelpfully)
+ registers &Perl_unimplemented_op as the address of their custom op.
NULL doesn't generate a useful error message. "custom" does. */
const char *const name = op_type >= OP_max
- ? "[out of range]" : PL_op_name[PL_op->op_type];
+ ? "[out of range]" : PL_op_name[op_type];
if(OP_IS_SOCKET(op_type))
DIE(aTHX_ PL_no_sock_func, name);
DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
PP(pp_avhvswitch)
{
- dVAR; dSP;
+ dSP;
return PL_ppaddr[
(SvTYPE(TOPs) == SVt_PVAV ? OP_AEACH : OP_EACH)
+ (PL_op->op_private & OPpAVHVSWITCH_MASK)
return NORMAL;
}
+PP(pp_isa)
+{
+ dSP;
+ SV *left, *right;
+
+ right = POPs;
+ left = TOPs;
+
+ SETs(boolSV(sv_isa_sv(left, right)));
+ RETURN;
+}
+
+PP(pp_cmpchain_and)
+{
+ dSP;
+ SV *result = POPs;
+ PUTBACK;
+ if (SvTRUE_NN(result)) {
+ return cLOGOP->op_other;
+ } else {
+ TOPs = result;
+ return NORMAL;
+ }
+}
+
+PP(pp_cmpchain_dup)
+{
+ dSP;
+ SV *right = TOPs;
+ SV *left = TOPm1s;
+ TOPm1s = right;
+ TOPs = left;
+ XPUSHs(right);
+ RETURN;
+}
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff