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/glue.h"
19
20namespace pm { namespace perl { namespace glue {
21namespace {
22
23int Item_flags_index, Item_custom_flag, Item_changed_flag, Settings_changed_index;
24
25bool is_local_change(pTHX)
26{
27   if (PL_localizing)
28      return true;
29   switch (PL_op->op_type) {
30   case OP_AELEM:
31   case OP_DELETE:
32   case OP_POP:
33   case OP_SHIFT:
34#if PerlVersion >= 5220
35   case OP_MULTIDEREF:
36#endif
37      return PL_op->op_private & OPpLVAL_INTRO;
38   case OP_LEAVE:
39   case OP_LEAVESUB:
40   case OP_LEAVESUBLV:
41   case OP_LEAVEEVAL:
42   case OP_LEAVELOOP:
43      return true;
44   }
45   return false;
46}
47
48int set_changed_flag(pTHX_ SV *sv, MAGIC* mg)
49{
50   if (!is_local_change(aTHX)) {
51      SV* item_flags_sv = AvARRAY(SvRV(mg->mg_obj))[Item_flags_index];
52      IV flags = SvIV(item_flags_sv);
53      flags |= Item_custom_flag | Item_changed_flag;
54      sv_setiv(item_flags_sv, flags);
55      SV* settings_sv = AvARRAY((SV*)mg->mg_ptr)[Settings_changed_index];
56      sv_setiv(settings_sv, 1);
57   }
58   return 0;
59}
60
61void add_change_monitor(pTHX_ SV* sv, SV* item, SV* self);
62
63int copy_change_monitor(pTHX_ SV*, MAGIC* mg, SV* nsv, const char*, mg_copy_index_t)
64{
65   add_change_monitor(aTHX_ nsv, mg->mg_obj, (SV*)mg->mg_ptr);
66   return 0;
67}
68
69int no_local_monitor(pTHX_ SV*, MAGIC*)
70{
71   return 0;
72}
73
74MGVTBL change_monitor_vtbl{
75   nullptr, &set_changed_flag, nullptr, &set_changed_flag, nullptr,
76   &copy_change_monitor, &monitored_dup, &no_local_monitor };
77
78void add_change_monitor(pTHX_ AV* av, SV* item, SV* self)
79{
80   const SSize_t last = AvFILLp(av);
81   if (last >= 0) {
82      for (SV **svp = AvARRAY(av), **lastp = svp + last;  svp <= lastp;  ++svp) {
83         SV* elem = *svp;
84         if (elem)
85            add_change_monitor(aTHX_ elem, item, self);
86      }
87   }
88}
89
90void add_change_monitor(pTHX_ HV* hv, SV* item, SV* self)
91{
92   if (hv_iterinit(hv)) {
93      while (HE* he = hv_iternext(hv)) {
94         SV* val = HeVAL(he);
95         add_change_monitor(aTHX_ val, item, self);
96      }
97   }
98}
99
100void add_change_monitor(pTHX_ SV* sv, SV* item, SV* self)
101{
102   if (SvROK(sv)) {
103      SV* target = SvRV(sv);
104      if (!SvOBJECT(target)) {
105         if (SvTYPE(target) == SVt_PVAV) {
106            add_change_monitor(aTHX_ (AV*)target, item, self);
107            sv = target;
108         } else if (SvTYPE(target) == SVt_PVHV) {
109            add_change_monitor(aTHX_ (HV*)target, item, self);
110            sv = target;
111         } else if (SvTYPE(target) <= SVt_PVMG) {
112            sv = target;
113         }
114      }
115   }
116   MAGIC* mg = sv_magicext(sv, item, PERL_MAGIC_ext, &change_monitor_vtbl, (char*)self, 0);
117   mg->mg_flags |= MGf_LOCAL;
118}
119
120bool deserves_reset(pTHX_ MAGIC* mg)
121{
122   SV* item_flags_sv = AvARRAY(SvRV(mg->mg_obj))[Item_flags_index];
123   IV flags = SvIV(item_flags_sv);
124   if (flags & Item_custom_flag) {
125      flags &= ~Item_custom_flag;
126      flags |= Item_changed_flag;
127      sv_setiv(item_flags_sv, flags);
128      SV* settings_sv = AvARRAY((SV*)mg->mg_ptr)[Settings_changed_index];
129      sv_setiv(settings_sv, 1);
130      return true;
131   }
132   return false;
133}
134
135bool reset_custom_var(pTHX_ SV* sv, SV** SP, I32 sp_offset = 0)
136{
137   MAGIC* mg;
138   if (!SvSMAGICAL(sv) || !(mg = get_monitored_magic(sv)))
139      return false;
140   if (deserves_reset(aTHX_ mg)) {
141      PUSHMARK(SP + sp_offset - 1);
142      SP[sp_offset] = mg->mg_obj;
143      mg->mg_virtual = nullptr;
144      Perl_call_method(aTHX_ "reset_value", G_VOID | G_DISCARD);
145      mg->mg_virtual = &change_monitor_vtbl;
146   }
147   return true;
148}
149
150OP* reset_custom_sv(pTHX)
151{
152   dSP;
153   SV* sv = TOPs;
154   if (!sv || SvTYPE(sv) < SVt_PVMG || !reset_custom_var(aTHX_ sv, SP))
155      DIE(aTHX_ "not a custom variable");
156   return NORMAL;
157}
158
159OP* reset_custom_helem(pTHX)
160{
161   dSP;
162   SV* hv = TOPm1s;
163   if (!reset_custom_var(aTHX_ hv, SP, -1))
164      DIE(aTHX_ "not a custom hash element");
165   return NORMAL;
166}
167
168OP* reset_custom_hslice(pTHX)
169{
170   dSP;
171   SV* hv = TOPs;
172   MAGIC* mg;
173   if (SvSMAGICAL(hv) && (mg = get_monitored_magic(hv))) {
174      SV** firstkey = PL_stack_base+TOPMARK+1;
175      if (firstkey < SP && deserves_reset(aTHX_ mg)) {
176         // the order of keys does not play any role, can be permuted to avoid full move
177         SP[0] = *firstkey;
178         *firstkey = mg->mg_obj;
179         mg->mg_virtual = nullptr;
180         Perl_call_method(aTHX_ "reset_value", G_VOID | G_DISCARD);
181         mg->mg_virtual = &change_monitor_vtbl;
182      } else {
183         dMARK;
184         SP = MARK;
185         PUTBACK;
186      }
187      return NORMAL;
188   }
189   DIE(aTHX_ "not a custom hash element");
190}
191
192OP* prepare_reset_custom(pTHX_ OP* o)
193{
194   OP* gvop = cUNOPo->op_first;
195   if (gvop->op_type != OP_GV) {
196      report_parse_error("wrong use of reset_custom; expecting plain package variable");
197      return nullptr;
198   }
199   o->op_flags |= OPf_REF;
200   OP* full_op = newUNOP(OP_NULL, OPf_WANT_VOID, o);
201   full_op->op_type = OP_CUSTOM;
202   full_op->op_ppaddr = reset_custom_sv;
203   return full_op;
204}
205
206OP* prepare_reset_custom_helem(pTHX_ OP* o)
207{
208   OP* rvop = cUNOPo->op_first;
209   if (rvop->op_type != OP_RV2HV || cUNOPx(rvop)->op_first->op_type != OP_GV) {
210      report_parse_error("wrong use of reset_custom; expecting plain package variable");
211      return nullptr;
212   }
213   o->op_type = OP_CUSTOM;
214   o->op_ppaddr = &reset_custom_helem;
215   clear_bit_flags(o->op_flags, OPf_WANT);
216   set_bit_flags(o->op_flags, OPf_WANT_VOID);
217   return o;
218}
219
220OP* prepare_reset_custom_hslice(pTHX_ OP* o)
221{
222   OP* rvop = cLISTOPo->op_last;
223   if (rvop->op_type != OP_RV2HV || cUNOPx(rvop)->op_first->op_type != OP_GV) {
224      report_parse_error("wrong use of reset_custom; expecting plain package variable");
225      return KEYWORD_PLUGIN_DECLINE;
226   }
227   o->op_type = OP_CUSTOM;
228   o->op_ppaddr = &reset_custom_hslice;
229   clear_bit_flags(o->op_flags, OPf_WANT);
230   set_bit_flags(o->op_flags, OPf_WANT_VOID);
231   return o;
232}
233
234}
235
236int monitored_dup(pTHX_ MAGIC* mg, CLONE_PARAMS* param)
237{
238   return 0;
239}
240
241int parse_set_custom(pTHX_ OP** op_ptr)
242{
243   op_keeper<OP> o(aTHX_ parse_termexpr(0));
244   if (o) {
245      if (o->op_type == OP_SASSIGN || o->op_type == OP_AASSIGN) {
246         *op_ptr = o.release();
247         return KEYWORD_PLUGIN_EXPR;
248      }
249      report_parse_error("set_custom can only be combined with an assignment");
250   }
251   return KEYWORD_PLUGIN_DECLINE;
252}
253
254int parse_reset_custom(pTHX_ OP** op_ptr)
255{
256   op_keeper<OP> o(aTHX_ parse_termexpr(0));
257   if (o) {
258      OP* full_op = nullptr;
259      switch (o->op_type) {
260      case OP_RV2SV:
261         full_op = prepare_reset_custom(aTHX_ o);
262         break;
263      case OP_RV2AV:
264         full_op = prepare_reset_custom(aTHX_ o);
265         break;
266      case OP_RV2HV:
267         full_op = prepare_reset_custom(aTHX_ o);
268         break;
269      case OP_HELEM:
270         full_op = prepare_reset_custom_helem(aTHX_ o);
271         break;
272      case OP_HSLICE:
273         full_op = prepare_reset_custom_hslice(aTHX_ o);
274         break;
275      default:
276         report_parse_error("reset_custom is only applicable to scalar, array, hash variables, or hash elements/slices");
277         break;
278      }
279      if (full_op) {
280         *op_ptr = full_op;
281         o.release();
282         return KEYWORD_PLUGIN_STMT;
283      }
284   }
285   return KEYWORD_PLUGIN_DECLINE;
286}
287
288} } }
289
290using namespace pm::perl::glue;
291
292MODULE = Polymake::Core::UserSettings              PACKAGE = Polymake::Core::UserSettings
293
294PROTOTYPES: DISABLE
295
296void add_change_monitor(SV* self, SV* item, SV* ref)
297PPCODE:
298{
299   if (!SvROK(ref) || !(SvROK(item) && SvOBJECT(SvRV(item))) ||
300       !(SvROK(self) && (self = SvRV(self), SvOBJECT(self))))
301      croak_xs_usage(cv, "UserSettings, Item, \\data");
302   add_change_monitor(aTHX_ ref, item, self);
303}
304
305void drop_change_monitor(SV* ref)
306PPCODE:
307{
308   if (!SvROK(ref))
309      croak_xs_usage(cv, "\\data");
310   mg_free_type(SvRV(ref), PERL_MAGIC_ext);
311}
312
313void get_item(SV* ref)
314PPCODE:
315{
316   if (!SvROK(ref))
317      croak_xs_usage(cv, "\\data");
318   if (MAGIC* mg = get_monitored_magic(SvRV(ref))) {
319      PUSHs(mg->mg_obj);
320      PUTBACK;
321   }
322}
323
324BOOT:
325{
326   HV* item_flags_stash = get_named_stash(aTHX_ "Polymake::Core::UserSettings::Item::Flags");
327   Item_custom_flag = get_named_constant(aTHX_ item_flags_stash, "is_custom");
328   Item_changed_flag = get_named_constant(aTHX_ item_flags_stash, "is_changed");
329   Item_flags_index = CvDEPTH(get_cv("Polymake::Core::UserSettings::Item::flags", false));
330   Settings_changed_index = CvDEPTH(get_cv("Polymake::Core::UserSettings::changed", false));
331}
332
333=pod
334// Local Variables:
335// mode:C++
336// c-basic-offset:3
337// indent-tabs-mode:nil
338// End:
339=cut
340