#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
static I32 sortcv(pTHXo_ SV *a, SV *b);
+static I32 sortcv_stacked(pTHXo_ SV *a, SV *b);
+static I32 sortcv_xsub(pTHXo_ SV *a, SV *b);
static I32 sv_ncmp(pTHXo_ SV *a, SV *b);
static I32 sv_i_ncmp(pTHXo_ SV *a, SV *b);
static I32 amagic_ncmp(pTHXo_ SV *a, SV *b);
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
+ if (DO_UTF8(tmpstr))
+ pm->op_pmdynflags |= PMdf_UTF8;
pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
else if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
+ /* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
+#if !defined(USE_ITHREADS) && !defined(USE_THREADS)
+ /* XXX can't change the optree at runtime either */
cLOGOP->op_first->op_next = PL_op->op_next;
+#endif
}
RETURN;
}
NV value;
bool gotsome;
STRLEN len;
- STRLEN fudge = SvCUR(tmpForm) * (IN_UTF8 ? 3 : 1) + 1;
+ STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
+ bool item_is_utf = FALSE;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
SvREADONLY_off(tmpForm);
case FF_CHECKNL:
item = s = SvPV(sv, len);
itemsize = len;
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
itemsize = sv_len_utf8(sv);
if (itemsize != len) {
I32 itembytes;
break;
s++;
}
+ item_is_utf = TRUE;
itemsize = s - item;
sv_pos_b2u(sv, &itemsize);
break;
}
}
+ item_is_utf = FALSE;
if (itemsize > fieldsize)
itemsize = fieldsize;
send = chophere = s + itemsize;
case FF_CHECKCHOP:
item = s = SvPV(sv, len);
itemsize = len;
- if (IN_UTF8) {
+ if (DO_UTF8(sv)) {
itemsize = sv_len_utf8(sv);
if (itemsize != len) {
I32 itembytes;
itemsize = chophere - item;
sv_pos_b2u(sv, &itemsize);
}
+ item_is_utf = TRUE;
break;
}
}
+ item_is_utf = FALSE;
if (itemsize <= fieldsize) {
send = chophere = s + itemsize;
while (s < send) {
case FF_ITEM:
arg = itemsize;
s = item;
- if (IN_UTF8) {
+ if (item_is_utf) {
while (arg--) {
if (*s & 0x80) {
switch (UTF8SKIP(s)) {
case FF_LINEGLOB:
item = s = SvPV(sv, len);
itemsize = len;
+ item_is_utf = FALSE; /* XXX is this correct? */
if (itemsize) {
gotsome = TRUE;
send = s + itemsize;
I32 gimme = GIMME;
OP* nextop = PL_op->op_next;
I32 overloading = 0;
+ bool hasargs = FALSE;
+ I32 is_xsub = 0;
if (gimme != G_ARRAY) {
SP = MARK;
}
else {
cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ if (cv && SvPOK(cv)) {
+ STRLEN n_a;
+ char *proto = SvPV((SV*)cv, n_a);
+ if (proto && strEQ(proto, "$$")) {
+ hasargs = TRUE;
+ }
+ }
if (!(cv && CvROOT(cv))) {
- if (gv) {
+ if (cv && CvXSUB(cv)) {
+ is_xsub = 1;
+ }
+ else if (gv) {
SV *tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, Nullch);
- if (cv && CvXSUB(cv))
- DIE(aTHX_ "Xsub \"%s\" called in sort", SvPVX(tmpstr));
DIE(aTHX_ "Undefined sort subroutine \"%s\" called",
SvPVX(tmpstr));
}
- if (cv) {
- if (CvXSUB(cv))
- DIE(aTHX_ "Xsub called in sort");
+ else {
DIE(aTHX_ "Undefined subroutine in sort");
}
- DIE(aTHX_ "Not a CODE reference in sort");
}
- PL_sortcop = CvSTART(cv);
- SAVEVPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
- SAVEVPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ if (is_xsub)
+ PL_sortcop = (OP*)cv;
+ else {
+ PL_sortcop = CvSTART(cv);
+ SAVEVPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+
+ SAVEVPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ }
}
}
else {
PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
if (!(PL_op->op_flags & OPf_SPECIAL)) {
- bool hasargs = FALSE;
cx->cx_type = CXt_SUB;
cx->blk_gimme = G_SCALAR;
PUSHSUB(cx);
(void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
}
PL_sortcxix = cxstack_ix;
- qsortsv((myorigmark+1), max, sortcv);
+
+ if (hasargs && !is_xsub) {
+ /* This is mostly copied from pp_entersub */
+ AV *av = (AV*)PL_curpad[0];
+
+#ifndef USE_THREADS
+ cx->blk_sub.savearray = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+ cx->blk_sub.argarray = av;
+ }
+ qsortsv((myorigmark+1), max,
+ is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
POPBLOCK(cx,PL_curpm);
PL_stack_sp = newsp;
mg_get(right);
if (SvNIOKp(left) || !SvPOKp(left) ||
- (looks_like_number(left) && *SvPVX(left) != '0') )
+ SvNIOKp(right) || !SvPOKp(right) ||
+ (looks_like_number(left) && *SvPVX(left) != '0' &&
+ looks_like_number(right) && *SvPVX(right) != '0'))
{
if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
else if (PL_errors)
sv_catsv(PL_errors, err);
else
- Perl_warn(aTHX_ "%_", err);
+ Perl_warn(aTHX_ "%"SVf, err);
++PL_error_count;
}
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
if (SvNIOKp(sv) || !SvPOKp(sv) ||
- (looks_like_number(sv) && *SvPVX(sv) != '0')) {
+ SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
+ (looks_like_number(sv) && *SvPVX(sv) != '0' &&
+ looks_like_number((SV*)cx->blk_loop.iterary) &&
+ *SvPVX(cx->blk_loop.iterary) != '0'))
+ {
if (SvNV(sv) < IV_MIN ||
SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"last\" outside a block");
+ DIE(aTHX_ "Can't \"last\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"next\" outside a block");
+ DIE(aTHX_ "Can't \"next\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
if (cxix < cxstack_ix)
dounwind(cxix);
- TOPBLOCK(cx);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- return cx->blk_loop.next_op;
+ cx = &cxstack[cxstack_ix];
+ {
+ OP *nextop = cx->blk_loop.next_op;
+ /* clean scope, but only if there's no continue block */
+ if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
+ TOPBLOCK(cx);
+ oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ }
+ return nextop;
+ }
}
PP(pp_redo)
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < 0)
- DIE(aTHX_ "Can't \"redo\" outside a block");
+ DIE(aTHX_ "Can't \"redo\" outside a loop block");
}
else {
cxix = dopoptolabel(cPVOP->op_pv);
/* FALL THROUGH */
case CXt_FORMAT:
case CXt_NULL:
- DIE(aTHX_ "Can't \"goto\" outside a block");
+ DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
default:
if (ix)
DIE(aTHX_ "panic: goto");
/* Eventually we may want to stack the needed arguments
* for each op. For now, we punt on the hard ones. */
if (PL_op->op_type == OP_ENTERITER)
- DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop",
- label);
+ DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
CALL_FPTR(PL_op->op_ppaddr)(aTHX);
}
PL_op = oldop;
anum = 0;
#endif
}
+ PL_exit_flags |= PERL_EXIT_EXPECTED;
my_exit(anum);
PUSHs(&PL_sv_undef);
RETURN;
SV *filter_sub = 0;
sv = POPs;
- if (SvNIOKp(sv) && !SvPOKp(sv)) {
- if (Atof(PL_patchlevel) + 0.00000999 < SvNV(sv))
- DIE(aTHX_ "Perl %s required--this is only version %s, stopped",
- SvPV(sv,n_a),PL_patchlevel);
+ if (SvNIOKp(sv)) {
+ UV rev, ver, sver;
+ if (SvPOKp(sv) && SvUTF8(sv)) { /* require v5.6.1 */
+ I32 len;
+ U8 *s = (U8*)SvPVX(sv);
+ U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
+ if (s < end) {
+ rev = utf8_to_uv(s, &len);
+ s += len;
+ if (s < end) {
+ ver = utf8_to_uv(s, &len);
+ s += len;
+ if (s < end)
+ sver = utf8_to_uv(s, &len);
+ else
+ sver = 0;
+ }
+ else
+ ver = 0;
+ }
+ else
+ rev = 0;
+ if (PERL_REVISION < rev
+ || (PERL_REVISION == rev
+ && (PERL_VERSION < ver
+ || (PERL_VERSION == ver
+ && PERL_SUBVERSION < sver))))
+ {
+ DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
+ "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
+ PERL_VERSION, PERL_SUBVERSION);
+ }
+ }
+ else if (!SvPOKp(sv)) { /* require 5.005_03 */
+ NV n = SvNV(sv);
+ rev = (UV)n;
+ ver = (UV)((n-rev)*1000);
+ sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
+
+ if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
+ + ((NV)PERL_SUBVERSION/(NV)1000000)
+ + 0.00000099 < SvNV(sv))
+ {
+ DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
+ "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
+ PERL_VERSION, PERL_SUBVERSION);
+ }
+ }
RETPUSHYES;
}
name = SvPV(sv, len);
return result;
}
+static I32
+sortcv_stacked(pTHXo_ SV *a, SV *b)
+{
+ dTHR;
+ I32 oldsaveix = PL_savestack_ix;
+ I32 oldscopeix = PL_scopestack_ix;
+ I32 result;
+ AV *av;
+
+#ifdef USE_THREADS
+ av = (AV*)PL_curpad[0];
+#else
+ av = GvAV(PL_defgv);
+#endif
+
+ if (AvMAX(av) < 1) {
+ SV** ary = AvALLOC(av);
+ if (AvARRAY(av) != ary) {
+ AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+ SvPVX(av) = (char*)ary;
+ }
+ if (AvMAX(av) < 1) {
+ AvMAX(av) = 1;
+ Renew(ary,2,SV*);
+ SvPVX(av) = (char*)ary;
+ }
+ }
+ AvFILLp(av) = 1;
+
+ AvARRAY(av)[0] = a;
+ AvARRAY(av)[1] = b;
+ PL_stack_sp = PL_stack_base;
+ PL_op = PL_sortcop;
+ CALLRUNOPS(aTHX);
+ if (PL_stack_sp != PL_stack_base + 1)
+ Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+ if (!SvNIOKp(*PL_stack_sp))
+ Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+ result = SvIV(*PL_stack_sp);
+ while (PL_scopestack_ix > oldscopeix) {
+ LEAVE;
+ }
+ leave_scope(oldsaveix);
+ return result;
+}
+
+static I32
+sortcv_xsub(pTHXo_ SV *a, SV *b)
+{
+ dSP;
+ I32 oldsaveix = PL_savestack_ix;
+ I32 oldscopeix = PL_scopestack_ix;
+ I32 result;
+ CV *cv=(CV*)PL_sortcop;
+
+ SP = PL_stack_base;
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ *++SP = a;
+ *++SP = b;
+ PUTBACK;
+ (void)(*CvXSUB(cv))(aTHXo_ cv);
+ if (PL_stack_sp != PL_stack_base + 1)
+ Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+ if (!SvNIOKp(*PL_stack_sp))
+ Perl_croak(aTHX_ "Sort subroutine didn't return a numeric value");
+ result = SvIV(*PL_stack_sp);
+ while (PL_scopestack_ix > oldscopeix) {
+ LEAVE;
+ }
+ leave_scope(oldsaveix);
+ return result;
+}
+
static I32
sv_ncmp(pTHXo_ SV *a, SV *b)
projects / p5sagit/p5-mst-13.2.git / blobdiff