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 ©_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