--- ./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 ""