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