--- ./lib/core/src/perl/Struct.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/Struct.xs 2013-01-10 09:48:02.893665535 -0700
@@ -223,13 +223,6 @@ OP* pp_method_call(pTHX)
return Perl_pp_method_named(aTHX);
}
-static inline
-OP* method_named_op(OP *o)
-{
- return ((o->op_flags & OPf_KIDS) &&
- (o=cUNOPo->op_first->op_sibling) && (o=o->op_sibling) && o->op_type == OP_METHOD_NAMED) ? o : 0;
-}
-
static
OP* intercept_ck_aassign(pTHX_ OP* o)
{
@@ -238,7 +231,10 @@ OP* intercept_ck_aassign(pTHX_ OP* o)
lhs=cUNOPo->op_first->op_sibling;
if (lhs->op_type == OP_NULL) lhs=cUNOPx(lhs)->op_first;
while (lhs) {
- if (lhs->op_type == OP_ENTERSUB) lhs->op_private |= OPpENTERSUB_AASSIGN_LHS;
+ if (lhs->op_type == OP_ENTERSUB) {
+ OP* meth_op=method_named_op(lhs);
+ if (meth_op) meth_op->op_private |= MethodIsCalledOnLeftSideOfArrayAssignment;
+ }
lhs=lhs->op_sibling;
}
return o;
@@ -410,7 +406,7 @@ PPCODE:
o->op_ppaddr=&pp_method_call;
break;
default:
- o->op_ppaddr= PL_op->op_private & OPpENTERSUB_AASSIGN_LHS ? &pp_access : &pp_method_access;
+ o->op_ppaddr= (o->op_private & MethodIsCalledOnLeftSideOfArrayAssignment) ? &pp_access : &pp_method_access;
break;
}
} else {
@@ -425,7 +421,7 @@ PPCODE:
}
switch (next_op->op_type) {
default:
- if (!(o ? o->op_ppaddr == &pp_access : PL_op->op_private & OPpENTERSUB_AASSIGN_LHS)) {
+ if (!(o && o->op_ppaddr == &pp_access)) {
PUSHs(find_method(aTHX_ index, 0));
break;
}
--- ./lib/core/src/perl/Object.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/Object.xs 2013-01-10 09:41:58.985884887 -0700
@@ -58,8 +58,12 @@ PPCODE:
PUSHs(AvARRAY(descr)[2]);
}
o->op_ppaddr=&Perl_pp_null;
+#if PerlVersion >= 5160
+ /* remove the LVALUE flag */
+ PL_op->op_private &= ~OPpLVAL_INTRO;
+#endif
- } else if (PL_op->op_private & OPpENTERSUB_AASSIGN_LHS) {
+ } else if ((o=method_named_op(PL_op), o && (o->op_private & MethodIsCalledOnLeftSideOfArrayAssignment))) {
if (hide_args) Perl_croak(aTHX_ "unexpected scalar context within list assignment");
EXTEND(SP,items+3);
/* AASSIGN expects two marks: the topmost delimits the lvalues, the next below it - the rvalues */
@@ -69,6 +73,10 @@ PPCODE:
PUSHs(prop);
PUSHs(rhs);
PUSHs(AvARRAY(descr)[2]);
+#if PerlVersion >= 5160
+ /* remove the LVALUE flag */
+ PL_op->op_private &= ~OPpLVAL_INTRO;
+#endif
} else {
EXTEND(SP,items+2+hide_args);
--- ./lib/core/src/perl/RefHash.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/RefHash.xs 2013-01-10 09:46:13.844168283 -0700
@@ -666,7 +666,11 @@ OP* check_pushhv(pTHX_ OP *o)
kid = kid->op_sibling;
if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) {
int arg_cnt=2;
+#if PerlVersion >= 5160
+ op_lvalue(kid, o->op_type);
+#else
Perl_mod(aTHX_ kid, o->op_type);
+#endif
while ((kid=kid->op_sibling)) {
if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV) {
Perl_list(aTHX_ kid);
--- ./lib/core/src/perl/Poly.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/Poly.xs 2013-01-10 09:45:36.412035674 -0700
@@ -91,6 +91,26 @@ OP* pp_first(pTHX)
RETURN;
}
+#if PerlVersion >= 5160
+static
+OP* safe_magic_lvalue_return_op(pTHX)
+{
+ if (cxstack[cxstack_ix].blk_gimme==G_SCALAR) {
+ dSP;
+ OP* next_op;
+ SV* retval=TOPs;
+ U32 retval_flags= SvTEMP(retval) && SvREFCNT(retval)==1 ? SvMAGICAL(retval) : 0;
+ if (retval_flags) {
+ SvMAGICAL_off(retval);
+ next_op=Perl_pp_leavesub(aTHX);
+ SvFLAGS(retval) |= retval_flags;
+ return next_op;
+ }
+ }
+ return Perl_pp_leavesub(aTHX);
+}
+#endif
+
MGVTBL pm_perl_array_flags_vtbl={ 0, 0, 0, 0, 0 };
static inline
@@ -255,7 +275,7 @@ PPCODE:
else
PUSHs(&PL_sv_no);
} else if (CvFLAGS(sub) & CVf_LVALUE) {
- if (!CvXSUB(sub) && CvROOT(sub)->op_type==OP_LEAVESUBLV)
+ if (!CvISXSUB(sub) && CvROOT(sub)->op_type==OP_LEAVESUBLV)
PUSHs(&PL_sv_no); /* not faked */
else
PUSHs(&PL_sv_yes);
@@ -271,12 +291,21 @@ CODE:
{
CV *sub;
if (!SvROK(subref) || (sub=(CV*)SvRV(subref), SvTYPE(sub) != SVt_PVCV))
- croak_xs_usage(cv, "\\&sub");
+ croak_xs_usage(cv, "\\&sub [, TRUE_if_faked ]");
CvFLAGS(sub) |= CVf_LVALUE | CVf_NODEBUG;
- if (!CvXSUB(sub) && (items==1 || !SvTRUE(ST(1)))) {
+ if (!CvISXSUB(sub)) {
OP *leave_op=CvROOT(sub);
- leave_op->op_type=OP_LEAVESUBLV;
- leave_op->op_ppaddr=PL_ppaddr[OP_LEAVESUBLV];
+ if (items==1 || !SvTRUE(ST(1))) {
+ /* not faked */
+ leave_op->op_type=OP_LEAVESUBLV;
+ leave_op->op_ppaddr=PL_ppaddr[OP_LEAVESUBLV];
+ }
+#if PerlVersion >= 5160
+ else {
+ /* nowadays perl is fond of copying return values if they show any magic */
+ leave_op->op_ppaddr=&safe_magic_lvalue_return_op;
+ }
+#endif
}
}
@@ -682,8 +711,7 @@ is_real_code(x)
PROTOTYPE: $
PPCODE:
{
- if (SvROK(x) && (x=SvRV(x), SvTYPE(x) == SVt_PVCV)
- && (CvROOT((CV*)x) || CvXSUB((CV*)x)))
+ if (SvROK(x) && (x=SvRV(x), SvTYPE(x) == SVt_PVCV) && IsWellDefinedSub((CV*)x))
return; /* keep the CV reference on the stack */
XSRETURN_NO;
}
@@ -874,9 +902,7 @@ if (!SvROK(sub) ||
if (SvTYPE(glob) != SVt_PVGV)
gv_init(glob, pkg_stash, name, namelen, GV_ADDMULTI);
- if ((flags & 2) &&
- (was_here=GvCV(glob)) &&
- (CvROOT(was_here) || (CvXSUB(was_here)))) {
+ if ((flags & 2) && (was_here=GvCV(glob)) && IsWellDefinedSub(was_here)) {
if (GIMME_V != G_VOID)
PUSHs(sv_2mortal(newRV((SV*)was_here)));
@@ -885,7 +911,7 @@ if (!SvROK(sub) ||
if (CvANON(sub)) {
CvANON_off(sub);
CvGV_set((CV*)sub, glob);
- if (!CvXSUB(sub)) {
+ if (!CvISXSUB(sub)) {
SV *file=CopFILESV((COP*)CvSTART(sub));
if (file && (!SvOK(file) || !SvPVX(file) || !strncmp(SvPVX(file), "(eval ", 6)))
sv_setpvf(file, "(%s::%.*s)", HvNAME(pkg_stash), (int)namelen, name);
--- ./lib/core/src/perl/createBootstrap.pl.orig 2011-10-30 16:36:53.000000000 -0600
+++ ./lib/core/src/perl/createBootstrap.pl 2013-01-10 09:48:34.960079680 -0700
@@ -1,6 +1,6 @@
-# Copyright (c) 1997-2011
+# Copyright (c) 1997-2012
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
-# http://www.polymake.de
+# http://www.polymake.org
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
@@ -27,7 +27,7 @@ foreach my $file (@ARGV) {
open my $C, $file or die "can't read $file: $!\n";
my $ugly_cast= $] <= 5.008 && "(char*)";
while (<$C>) {
- if (/^XS\((boot_(\w+))\);/) {
+ if (/^XS(?:_EXTERNAL)?\((boot_(\w+))\);/) {
$proto .= "$&\n";
my $func=$1;
(my $pkg=$2) =~ s/_/:/g;
--- ./lib/core/src/perl/Ext.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/Ext.xs 2013-01-10 09:40:42.551339010 -0700
@@ -33,7 +33,11 @@ SV** pm_perl_get_cx_curpad(pTHX_ PERL_CO
goto FOUND;
case CXt_EVAL:
if (!CxTRYBLOCK(cx)) {
+#if PerlVersion >= 5120
+ cv=cx->blk_eval.cv;
+#else
cv=PL_compcv;
+#endif
d=0;
goto FOUND;
}
--- ./lib/core/src/perl/CPlusPlus.xxs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/CPlusPlus.xxs 2013-01-10 09:39:42.369023533 -0700
@@ -479,7 +479,7 @@ SV* clone_assoc_container_magic_sv(pTHX_
int canned_container_access(pTHX_ SV *sv, MAGIC* mg, SV *nsv, const char *dummy, PM_svt_copy_klen_arg index)
{
- OPCODE opc=PL_op->op_type;
+ const OPCODE opc=PL_op ? PL_op->op_type : OP_AELEM; // assume a plain array access when called directly from the callable library
const container_vtbl* const t=(const container_vtbl*)mg->mg_virtual;
char *obj=mg->mg_ptr, *it;
const container_access_vtbl *acct=t->acc+(mg->mg_flags & value_read_only);
--- ./lib/core/src/perl/namespaces.xs.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/src/perl/namespaces.xs 2013-01-10 09:50:40.332136877 -0700
@@ -697,7 +697,7 @@ GV* try_stored_lexical_gv(pTHX_ GV *var_
break;
case SVt_PVCV: {
CV *cv=GvCV(imp_gv);
- if (cv && (CvROOT(cv) || CvXSUB(cv))) return imp_gv;
+ if (cv && IsWellDefinedSub(cv)) return imp_gv;
}}
}
}
@@ -779,7 +779,7 @@ GV* test_imported_gv(GV *gv, I32 type, i
if (ignore_methods && CvMETHOD(cv))
/* may not discover methods in object-less call */
return (GV*)-1UL;
- if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv))
+ if (IsWellDefinedSub(cv) || GvASSUMECV(gv))
/* If only promised - let's try later, or die if the next op is ENTERSUB.
For inherited static methods return the gv from the basis class! */
return GvCVGEN(gv) ? CvGV(cv) : gv;
@@ -823,7 +823,7 @@ GV* lookup_name_in_list(pTHX_ HV *stash,
if (dotLOOKUP && (lookp=AvARRAY(dotLOOKUP))) {
for (endp=lookp+AvFILLp(dotLOOKUP); lookp<=endp; ++lookp)
if ((imp_gv=lookup_name_in_stash(aTHX_ (HV*)SvRV(*lookp), name, namelen, type, ignore_methods))) {
- if (type != SVt_PVCV || CvROOT(GvCV(imp_gv)) || CvXSUB(GvCV(imp_gv))) {
+ if (type != SVt_PVCV || IsWellDefinedSub(GvCV(imp_gv))) {
if (!var_gv) {
var_gv=*(GV**)hv_fetch(stash, name, namelen, TRUE);
if (SvTYPE(var_gv) != SVt_PVGV)
@@ -1227,7 +1227,7 @@ OP* intercept_pp_gv(pTHX)
lookup(aTHX_ var_gv, SVt_PVHV, &next_op, next_op);
break;
case OP_RV2CV:
- if ((cv=GvCV(var_gv)) && (next_op->op_next->op_type != OP_REFGEN || CvROOT(cv) || CvXSUB(cv)))
+ if ((cv=GvCV(var_gv)) && (next_op->op_next->op_type != OP_REFGEN || IsWellDefinedSub(cv)))
break;
lookup(aTHX_ var_gv, SVt_PVCV, &next_op, 0);
break;
@@ -1354,7 +1354,13 @@ OP* intercept_pp_aelemfast(pTHX)
{
OP *next_op=PL_op;
next_op->op_ppaddr=def_pp_AELEMFAST;
- if (!(next_op->op_flags & OPf_SPECIAL)) {
+#if PerlVersion < 5150
+ if (!(next_op->op_flags & OPf_SPECIAL))
+#else
+ /* since perl 5.16 AELEMFAST_LEX is a separate op */
+ if (next_op->op_type != OP_AELEMFAST_LEX)
+#endif
+ {
GV *var_gv=cGVOP_gv;
const char *name;
if (!GvIMPORTED_AV(var_gv)) {
--- ./lib/core/include/perl/Ext.h.orig 2011-12-20 17:47:59.000000000 -0700
+++ ./lib/core/include/perl/Ext.h 2013-01-10 09:37:30.278808742 -0700
@@ -1,6 +1,6 @@
-/* Copyright (c) 1997-2011
+/* Copyright (c) 1997-2012
Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
- http://www.polymake.de
+ http://www.polymake.org
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
@@ -67,6 +67,8 @@ EXTERN_C AV* Perl_av_fake(pTHX_ I32 size
#if PerlVersion >= 5100
# define ReturnsToOp(cx) (cx)->blk_sub.retop
+/* CvROOT and CvXSUB are in the same union */
+# define IsWellDefinedSub(x) (CvROOT(x))
# define PL_lex_brackets (PL_parser->lex_brackets)
# define PL_lex_state (PL_parser->lex_state)
# define PL_lex_inwhat (PL_parser->lex_inwhat)
@@ -81,6 +83,7 @@ EXTERN_C AV* Perl_av_fake(pTHX_ I32 size
# define PL_nextval (PL_parser->nextval)
#else
# define ReturnsToOp(cx) PL_retstack[(cx)->blk_oldretsp-1]
+# define IsWellDefinedSub(x) (CvROOT(x) || CvXSUB(x))
# ifndef SvRV_set
# define SvRV_set(ref,what) SvRV(ref)=(what)
# endif
@@ -134,8 +137,8 @@ EXTERN_C AV* Perl_av_fake(pTHX_ I32 size
#define LEX_KNOWNEXT 0
#define LEX_NORMAL 10
-/* check whether this private flag is free for each new perl release */
-#define OPpENTERSUB_AASSIGN_LHS 1
+/* check whether this private flag is not used in OP_METHOD_NAMED for each new perl release */
+#define MethodIsCalledOnLeftSideOfArrayAssignment 1
START_EXTERN_C
@@ -191,6 +194,13 @@ void write_protect_off(pTHX_ SV *x)
{
if (x != &PL_sv_undef) SvREADONLY_off(x);
}
+
+/* for given OP_ENTERSUB, find the corresponding OP_METHOD_NAMED, or return NULL */
+static inline
+OP* method_named_op(OP *o)
+{
+ return ((o->op_flags & OPf_KIDS) && (o=cLISTOPo->op_last) && o->op_type == OP_METHOD_NAMED) ? o : 0;
+}
#endif
static inline
--- ./lib/callable/src/perl/Main.cc.orig 2012-01-11 07:07:49.000000000 -0700
+++ ./lib/callable/src/perl/Main.cc 2013-01-10 09:38:15.750704364 -0700
@@ -70,7 +70,7 @@ void emergency_cleanup()
# define addlibs ""
#endif
#if POLYMAKE_DEBUG
-# define scr_debug1 "$DebugLevel=1;"
+# define scr_debug1 "$DebugLevel=1; $DB::single=1;"
# define scr_debug2 "sub stop_here { print STDERR \"@_\\n\" if @_ } my $loaded=1;\n"
#else
# define scr_debug1 ""