1/* Copyright (c) 1997-2021 2 Ewgenij Gawrilow, Michael Joswig, and the polymake team 3 Technische Universität Berlin, Germany 4 https://polymake.org 5 6 This program is free software; you can redistribute it and/or modify it 7 under the terms of the GNU General Public License as published by the 8 Free Software Foundation; either version 2, or (at your option) any 9 later version: http://www.gnu.org/licenses/gpl.txt. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15-------------------------------------------------------------------------------- 16*/ 17 18#include "polymake/perl/Ext.h" 19 20namespace { 21 22OP* pp_reveal_args(pTHX) 23{ 24 dSP; 25 IV items =PTR2IV(*SP); 26 EXTEND(SP, items); 27 *SP = SP[items+1]; 28 SP += items; 29 RETURN; 30} 31 32OP* pp_move_lhs_to_rhs(pTHX) 33{ 34 dSP; 35 // the value returned from put/put_multi is on the stack top: 36 // insert it into the corresponding slot of the rhs list and replace it with undef here 37 SP[PL_markstack_ptr[-1] - PL_markstack_ptr[0]] = TOPs; 38 SETs(&PL_sv_undef); 39 RETURN; 40} 41 42} 43using namespace pm::perl; 44using namespace pm::perl::glue; 45 46MODULE = Polymake::Core::BigObject PACKAGE = Polymake::Core::BigObject 47 48PROTOTYPES: DISABLE 49 50void _prop_accessor(SV* self, ...) 51PPCODE: 52{ 53 AV* descr = (AV*)CvXSUBANY(cv).any_ptr; 54 SV* prop = AvARRAY(descr)[0], *rhs; 55 OP* o = PL_op->op_next; 56 I32 hide_args = GIMME_V != G_ARRAY ? 1 : 0; 57 I32 assign = 0; 58 59 if (o && o->op_type == OP_SASSIGN && !(o->op_private & OPpASSIGN_BACKWARDS)) { 60 // setting a property: $this->PROP=value; 61 EXTEND(SP, items+3+hide_args); 62 rhs=*SP; 63 PUSHMARK(SP); 64 if (hide_args) { 65 *(++SP)=NUM2PTR(SV*, items+2); 66 SP[items]=prop; 67 SP[items+1]=rhs; 68 SP[items+2]=AvARRAY(descr)[2]; 69 SP[items+3]=self; 70 } else { 71 SP+=items; 72 PUSHs(prop); 73 PUSHs(rhs); 74 PUSHs(AvARRAY(descr)[2]); 75 } 76 assign=OP_SASSIGN; 77#if PerlVersion >= 5275 78 } else if (o && o->op_type == OP_MULTICONCAT && (o->op_flags & OPf_STACKED)) { 79 Perl_croak(aTHX_ "Think twice before assigning string values to properties,\n" 80 "most probably there are much more suitable data types such as numbers, arrays, etc.\n" 81 "If this is in fact a Text property, please compose the value in a temporary variable first.\n" 82 "Direct assignment of concatenated or interpolated strings to properties is not supported yet." ); 83#endif 84 } else if ((o=method_named_op(PL_op), o && (o->op_private & MethodIsCalledOnLeftSideOfArrayAssignment))) { 85 // setting a property in a list assignment: (..., $this->PROP, ... )=(..., value, ...); 86 if (hide_args) Perl_croak(aTHX_ "unexpected scalar context within list assignment"); 87 EXTEND(SP, items+3); 88 // AASSIGN expects two marks: the topmost delimits the lvalues, the next below it - the rvalues 89 rhs=SP[PL_markstack_ptr[-1]-PL_markstack_ptr[0]+1]; 90 PUSHMARK(SP); 91 SP+=items; 92 PUSHs(prop); 93 PUSHs(rhs); 94 PUSHs(AvARRAY(descr)[2]); 95 assign=OP_AASSIGN; 96 97 } else { 98 // retrieving a property 99 EXTEND(SP, items+2+hide_args); 100 PUSHMARK(SP); 101 if (hide_args) { 102 *(++SP)=NUM2PTR(SV*, items+1); 103 SP[items]=prop; 104 SP[items+1]=AvARRAY(descr)[1]; 105 SP[items+2]=self; 106 } else { 107 SP+=items; 108 PUSHs(prop); 109 PUSHs(AvARRAY(descr)[1]); 110 } 111 } 112 113 // We must repeat OP_ENTERSUB in order to execute the get or put method 114 // Depending on context, an auxiliary operation can be added. 115 if ((o=cUNOP->op_first)->op_type != OP_CUSTOM) { 116 OP* reveal_op = newOP(OP_CUSTOM, 0); 117 OP* last_new_op = reveal_op; 118 OP* dummy_op = o; 119 120 // we need a dummy operation ponting to the next op to be executed 121 if (o->op_type == OP_NULL) { 122 o->op_type = OP_CUSTOM; 123 } else { 124 dummy_op = newOP(OP_CUSTOM, 0); 125 } 126 127 reveal_op->op_ppaddr = &pp_reveal_args; 128 dummy_op->op_next = reveal_op; 129 130 if (assign) { 131 OP* sub_op = newOP(OP_CUSTOM, 0); 132 clear_bit_flags(PL_op->op_private, OPpLVAL_INTRO); 133 sub_op->op_ppaddr = PL_op->op_ppaddr; 134 sub_op->op_flags = PL_op->op_flags & U8(~OPf_KIDS); 135 sub_op->op_private = PL_op->op_private; 136 reveal_op->op_next = sub_op; 137 if (assign == OP_SASSIGN) { 138 // Now we've hidden the arguments for put/put_multi from the current OP_ENTERSUB 139 // which would destroy all but the last one because of scalar context. 140 // They must be revealed before put/put_multi is called. 141 sub_op->op_next = PL_op->op_next->op_next; // skip OP_SASSIGN 142 last_new_op = sub_op; 143 } else { 144 // Value returned from put/put_lvalue must be moved from the left to the right hand side of the list assignment 145 // TODO: try to recognize list assignments in void context and skip this 146 OP* move_op = newOP(OP_CUSTOM, 0); 147 move_op->op_ppaddr = &pp_move_lhs_to_rhs; 148 sub_op->op_next = move_op; 149 move_op->op_next = PL_op->op_next; 150 OpMORESIB_set(sub_op, move_op); 151 last_new_op = move_op; 152 } 153 OpMORESIB_set(reveal_op, sub_op); 154 } else { 155 reveal_op->op_next = PL_op; 156 } 157 158 // include new OPs into the tree at places having further siblings (would have to deal with PERL_OP_PARENT otherwise...) 159 if (dummy_op == o) { 160 OpMORESIB_set(last_new_op, cUNOPo->op_first); 161 cUNOPo->op_first = reveal_op; 162 } else { 163 OpMORESIB_set(last_new_op, o); 164 OpMORESIB_set(dummy_op, reveal_op); 165 cUNOP->op_first = dummy_op; 166 } 167 o=dummy_op; 168 } 169 PL_op = hide_args ? o : o->op_next; 170} 171 172 173void _get_descend_path() 174PPCODE: 175{ 176 for (PERL_CONTEXT *cx_bottom = cxstack, *cx = cx_bottom + cxstack_ix; cx >= cx_bottom; --cx) { 177 if (CxTYPE(cx) == CXt_SUB && !skip_debug_frame(aTHX_ cx)) { 178 OP* o = cx->blk_sub.retop; 179 if (!o) break; // called from call_sv due to some magic 180 181 if (!(o->op_type == OP_LEAVESUB || // not the last operation in a sub (forwarding from get_multi to get) 182 o->op_type == OP_LEAVESUBLV || 183 (o->op_type == OP_LEAVE && // in debug mode spurious intermediate operations may appear 184 (o->op_next->op_type == OP_LEAVESUB || 185 o->op_next->op_type == OP_LEAVESUBLV)))) { 186#ifdef USE_ITHREADS 187 SV** saved_curpad = nullptr; 188#endif 189 OP* nop = o; 190 while (nop->op_type == OP_METHOD_NAMED && nop->op_next->op_type == OP_ENTERSUB) { 191#ifdef USE_ITHREADS 192 if (!saved_curpad) { 193 saved_curpad = PL_curpad; 194 PL_curpad = get_cx_curpad(aTHX_ cx, cx_bottom); 195 } 196#endif 197 SV* prop_name = cSVOPx_sv(nop); 198 XPUSHs(prop_name); 199 nop = nop->op_next->op_next; 200 } 201#ifdef USE_ITHREADS 202 if (saved_curpad) PL_curpad = saved_curpad; 203#endif 204 break; 205 } 206 } 207 } 208} 209 210void _expect_array_access() 211PPCODE: 212{ 213 SV* result = &PL_sv_no; 214 for (PERL_CONTEXT *const cx_bottom = cxstack, *const cx_top = cx_bottom + cxstack_ix, *cx = cx_top; cx >= cx_bottom; --cx) { 215 if (CxTYPE(cx) == CXt_SUB) { 216 if (!skip_debug_frame(aTHX_ cx)) { 217 OP* o = cx->blk_sub.retop; 218 for (; o && o->op_type == OP_LEAVE; o = o->op_next) ; 219 if (!o) { 220 if (cx->blk_gimme == G_ARRAY) result = &PL_sv_yes; 221 break; 222 } 223 if (o->op_type != OP_LEAVESUB && o->op_type != OP_LEAVESUBLV) { 224 if (o->op_type == OP_RV2AV) result = &PL_sv_yes; 225#if PerlVersion >= 5220 226 if (o->op_type == OP_MULTIDEREF) result = &PL_sv_yes; 227#endif 228 break; 229 } 230 } 231 } 232 } 233 XPUSHs(result); 234} 235 236MODULE = Polymake::Core::BigObject PACKAGE = Polymake::Core::BigObjectType 237 238void create_prop_accessor(SV* descr, SV* pkg) 239PPCODE: 240{ 241 SV* sub = newSV_type(SVt_PVCV); 242 HV* stash = nullptr; 243 CvXSUB(sub) = &XS_Polymake__Core__BigObject__prop_accessor; 244 CvFLAGS(sub) = CvFLAGS(cv) | CVf_ANON | CVf_LVALUE | CVf_METHOD | CVf_NODEBUG; 245 if (SvPOK(pkg)) 246 stash = gv_stashpv(SvPVX(pkg), TRUE); 247 else if (SvROK(pkg)) 248 stash = (HV*)SvRV(pkg); 249 CvSTASH_set((CV*)sub, stash); 250 CvXSUBANY(sub).any_ptr = SvREFCNT_inc_NN(SvRV(descr)); 251 PUSHs(sv_2mortal(newRV_noinc(sub))); 252} 253 254BOOT: 255if (PL_DBgv) { 256 CvNODEBUG_on(get_cv("Polymake::Core::BigObject::_prop_accessor", FALSE)); 257 CvNODEBUG_on(get_cv("Polymake::Core::BigObject::_get_descend_path", FALSE)); 258 CvNODEBUG_on(get_cv("Polymake::Core::BigObject::_expect_array_access", FALSE)); 259} 260 261=pod 262// Local Variables: 263// mode:C++ 264// c-basic-offset:3 265// indent-tabs-mode:nil 266// End: 267=cut 268