1 /* vi: set ft=xs : */
2 #define PERL_NO_GET_CONTEXT
3
4 #include "EXTERN.h"
5 #include "perl.h"
6 #include "XSUB.h"
7
8 #include "object_pad.h"
9 #include "class.h"
10 #include "slot.h"
11
12 #undef register_class_attribute
13
14 #include "perl-backcompat.c.inc"
15 #include "sv_setrv.c.inc"
16
17 #include "perl-additions.c.inc"
18 #include "force_list_keeping_pushmark.c.inc"
19 #include "optree-additions.c.inc"
20 #include "newOP_CUSTOM.c.inc"
21
22 /* Empty MGVTBL simply for locating instance slots AV */
23 static MGVTBL vtbl_slotsav = {};
24
25 typedef struct ClassAttributeRegistration ClassAttributeRegistration;
26
27 struct ClassAttributeRegistration {
28 ClassAttributeRegistration *next;
29
30 const char *name;
31 STRLEN permit_hintkeylen;
32
33 const struct ClassHookFuncs *funcs;
34 void *funcdata;
35 };
36
37 static ClassAttributeRegistration *classattrs = NULL;
38
register_class_attribute(const char * name,const struct ClassHookFuncs * funcs,void * funcdata)39 static void register_class_attribute(const char *name, const struct ClassHookFuncs *funcs, void *funcdata)
40 {
41 ClassAttributeRegistration *reg;
42 Newx(reg, 1, struct ClassAttributeRegistration);
43
44 reg->name = name;
45 reg->funcs = funcs;
46 reg->funcdata = funcdata;
47
48 if(funcs->permit_hintkey)
49 reg->permit_hintkeylen = strlen(funcs->permit_hintkey);
50 else
51 reg->permit_hintkeylen = 0;
52
53 reg->next = classattrs;
54 classattrs = reg;
55 }
56
57 struct ClassHookFuncs_v51 {
58 U32 ver;
59 U32 flags;
60 const char *permit_hintkey;
61
62 /* At ABIVERSION 51, callback funcs did not take a 'funcdata' parameter */
63 bool (*apply)(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr);
64 void (*post_add_slot)(pTHX_ ClassMeta *classmeta, SV *hookdata, SlotMeta *slotmeta);
65 };
66
classhook_compat_apply_v51(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)67 static bool classhook_compat_apply_v51(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
68 {
69 struct ClassHookFuncs_v51 *funcdata = _funcdata;
70 return (*funcdata->apply)(aTHX_ classmeta, value, hookdata_ptr);
71 }
72
classhook_compat_post_add_slot_v51(pTHX_ ClassMeta * classmeta,SV * hookdata,void * _funcdata,SlotMeta * slotmeta)73 static void classhook_compat_post_add_slot_v51(pTHX_ ClassMeta *classmeta, SV *hookdata, void *_funcdata, SlotMeta *slotmeta)
74 {
75 struct ClassHookFuncs_v51 *funcdata = _funcdata;
76 (*funcdata->post_add_slot)(aTHX_ classmeta, hookdata, slotmeta);
77 }
78
ObjectPad_register_class_attribute(pTHX_ const char * name,const struct ClassHookFuncs * funcs,void * funcdata)79 void ObjectPad_register_class_attribute(pTHX_ const char *name, const struct ClassHookFuncs *funcs, void *funcdata)
80 {
81 if(funcs->ver < 51)
82 croak("Mismatch in third-party class attribute ABI version field: module wants %d, we require >= 51\n",
83 funcs->ver);
84 if(funcs->ver > OBJECTPAD_ABIVERSION)
85 croak("Mismatch in third-party class attribute ABI version field: attribute supplies %d, module wants %d\n",
86 funcs->ver, OBJECTPAD_ABIVERSION);
87
88 if(!name || !(name[0] >= 'A' && name[0] <= 'Z'))
89 croak("Third-party class attribute names must begin with a capital letter");
90
91 if(!funcs->permit_hintkey)
92 croak("Third-party class attributes require a permit hinthash key");
93
94 if(funcs->ver < 57) {
95 funcdata = (void *)funcs;
96
97 struct ClassHookFuncs *compatfuncs;
98 Newxz(compatfuncs, 1, struct ClassHookFuncs);
99
100 compatfuncs->ver = OBJECTPAD_ABIVERSION;
101 compatfuncs->flags = funcs->flags;
102 compatfuncs->permit_hintkey = funcs->permit_hintkey;
103
104 if(funcs->apply)
105 compatfuncs->apply = &classhook_compat_apply_v51;
106 if(funcs->post_add_slot)
107 compatfuncs->post_add_slot = &classhook_compat_post_add_slot_v51;
108
109 funcs = (const struct ClassHookFuncs *)compatfuncs;
110 }
111
112 register_class_attribute(name, funcs, funcdata);
113 }
114
ObjectPad_mop_class_apply_attribute(pTHX_ ClassMeta * classmeta,const char * name,SV * value)115 void ObjectPad_mop_class_apply_attribute(pTHX_ ClassMeta *classmeta, const char *name, SV *value)
116 {
117 HV *hints = GvHV(PL_hintgv);
118
119 if(value && (!SvPOK(value) || !SvCUR(value)))
120 value = NULL;
121
122 ClassAttributeRegistration *reg;
123 for(reg = classattrs; reg; reg = reg->next) {
124 if(!strEQ(name, reg->name))
125 continue;
126
127 if(reg->funcs->permit_hintkey &&
128 (!hints || !hv_fetch(hints, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0)))
129 continue;
130
131 if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_NO_VALUE) && value)
132 croak("Attribute :%s does not permit a value", name);
133 if((reg->funcs->flags & OBJECTPAD_FLAG_ATTR_MUST_VALUE) && !value)
134 croak("Attribute :%s requires a value", name);
135
136 SV *hookdata = value;
137
138 if(reg->funcs->apply) {
139 if(!(*reg->funcs->apply)(aTHX_ classmeta, value, &hookdata, reg->funcdata))
140 return;
141 }
142
143 if(!classmeta->hooks)
144 classmeta->hooks = newAV();
145
146 struct ClassHook *hook;
147 Newx(hook, 1, struct ClassHook);
148
149 hook->funcs = reg->funcs;
150 hook->funcdata = reg->funcdata;
151 hook->hookdata = hookdata;
152
153 av_push(classmeta->hooks, (SV *)hook);
154
155 if(value && value != hookdata)
156 SvREFCNT_dec(value);
157
158 return;
159 }
160
161 croak("Unrecognised class attribute :%s", name);
162 }
163
164 /* TODO: get attribute */
165
166 #define get_classmeta_for(self) S_get_classmeta_for(aTHX_ self)
S_get_classmeta_for(pTHX_ SV * self)167 static ClassMeta *S_get_classmeta_for(pTHX_ SV *self)
168 {
169 HV *selfstash = SvSTASH(SvRV(self));
170 GV **gvp = (GV **)hv_fetchs(selfstash, "META", 0);
171 if(!gvp)
172 croak("Unable to find ClassMeta for %" SVf, SVfARG(HvNAME(selfstash)));
173
174 return NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*gvp))));
175 }
176
177 #define make_instance_slots(classmeta, slotsav, roleoffset) S_make_instance_slots(aTHX_ classmeta, slotsav, roleoffset)
S_make_instance_slots(pTHX_ const ClassMeta * classmeta,AV * slotsav,SLOTOFFSET roleoffset)178 static void S_make_instance_slots(pTHX_ const ClassMeta *classmeta, AV *slotsav, SLOTOFFSET roleoffset)
179 {
180 assert(classmeta->type == METATYPE_ROLE || roleoffset == 0);
181
182 if(classmeta->start_slotix) {
183 /* Superclass actually has some slots */
184 assert(classmeta->type == METATYPE_CLASS);
185 assert(classmeta->cls.supermeta->sealed);
186
187 make_instance_slots(classmeta->cls.supermeta, slotsav, 0);
188 }
189
190 AV *slots = classmeta->direct_slots;
191 I32 nslots = av_count(slots);
192
193 av_extend(slotsav, classmeta->next_slotix - 1 + roleoffset);
194
195 I32 i;
196 for(i = 0; i < nslots; i++) {
197 SlotMeta *slotmeta = (SlotMeta *)AvARRAY(slots)[i];
198 char sigil = SvPV_nolen(slotmeta->name)[0];
199
200 assert(av_count(slotsav) == slotmeta->slotix + roleoffset);
201
202 switch(sigil) {
203 case '$':
204 av_push(slotsav, newSV(0));
205 break;
206
207 case '@':
208 av_push(slotsav, newRV_noinc((SV *)newAV()));
209 break;
210
211 case '%':
212 av_push(slotsav, newRV_noinc((SV *)newHV()));
213 break;
214
215 default:
216 croak("ARGH: not sure how to handle a slot sigil %c\n", sigil);
217 }
218 }
219
220 if(classmeta->type == METATYPE_CLASS) {
221 U32 nroles;
222 RoleEmbedding **embeddings = mop_class_get_direct_roles(classmeta, &nroles);
223
224 assert(classmeta->type == METATYPE_CLASS || nroles == 0);
225
226 for(i = 0; i < nroles; i++) {
227 RoleEmbedding *embedding = embeddings[i];
228 ClassMeta *rolemeta = embedding->rolemeta;
229
230 assert(rolemeta->sealed);
231
232 make_instance_slots(rolemeta, slotsav, embedding->offset);
233 }
234 }
235 }
236
ObjectPad_get_obj_slotsav(pTHX_ SV * self,enum ReprType repr,bool create)237 SV *ObjectPad_get_obj_slotsav(pTHX_ SV *self, enum ReprType repr, bool create)
238 {
239 SV *rv = SvRV(self);
240
241 switch(repr) {
242 case REPR_NATIVE:
243 if(SvTYPE(rv) != SVt_PVAV)
244 croak("Not an ARRAY reference");
245
246 return rv;
247
248 case REPR_HASH:
249 case_REPR_HASH:
250 {
251 if(SvTYPE(rv) != SVt_PVHV)
252 croak("Not a HASH reference");
253 SV **slotssvp = hv_fetchs((HV *)rv, "Object::Pad/slots", create);
254 if(create && !SvOK(*slotssvp))
255 sv_setrv_noinc(*slotssvp, (SV *)newAV());
256
257 /* A method invoked during a superclass constructor of a classic perl
258 * class might encounter $self without slots. If this is the case we'll
259 * have to create the slots now
260 * https://rt.cpan.org/Ticket/Display.html?id=132263
261 */
262 if(!slotssvp) {
263 struct ClassMeta *classmeta = get_classmeta_for(self);
264 AV *slotsav = newAV();
265
266 make_instance_slots(classmeta, slotsav, 0);
267
268 slotssvp = hv_fetchs((HV *)rv, "Object::Pad/slots", TRUE);
269 sv_setrv_noinc(*slotssvp, (SV *)slotsav);
270 }
271 if(!SvROK(*slotssvp) || SvTYPE(SvRV(*slotssvp)) != SVt_PVAV)
272 croak("Expected $self->{\"Object::Pad/slots\"} to be an ARRAY reference");
273 return SvRV(*slotssvp);
274 }
275
276 case REPR_MAGIC:
277 case_REPR_MAGIC:
278 {
279 MAGIC *mg = mg_findext(rv, PERL_MAGIC_ext, &vtbl_slotsav);
280 if(!mg && create)
281 mg = sv_magicext(rv, (SV *)newAV(), PERL_MAGIC_ext, &vtbl_slotsav, NULL, 0);
282 if(!mg)
283 croak("Expected to find slots AV magic extension");
284 return mg->mg_obj;
285 }
286
287 case REPR_AUTOSELECT:
288 if(SvTYPE(rv) == SVt_PVHV)
289 goto case_REPR_HASH;
290 goto case_REPR_MAGIC;
291 }
292
293 croak("ARGH unhandled repr type");
294 }
295
296 #define embed_cv(cv, embedding) S_embed_cv(aTHX_ cv, embedding)
S_embed_cv(pTHX_ CV * cv,RoleEmbedding * embedding)297 static CV *S_embed_cv(pTHX_ CV *cv, RoleEmbedding *embedding)
298 {
299 assert(cv);
300 assert(CvOUTSIDE(cv));
301
302 CV *embedded_cv = cv_clone(cv);
303 SV *embeddingsv = embedding->embeddingsv;
304
305 assert(SvTYPE(embeddingsv) == SVt_PV && SvLEN(embeddingsv) >= sizeof(RoleEmbedding));
306
307 PAD *pad1 = PadlistARRAY(CvPADLIST(embedded_cv))[1];
308 PadARRAY(pad1)[PADIX_EMBEDDING] = SvREFCNT_inc(embeddingsv);
309
310 return embedded_cv;
311 }
312
ObjectPad_mop_class_get_direct_roles(pTHX_ const ClassMeta * meta,U32 * nroles)313 RoleEmbedding **ObjectPad_mop_class_get_direct_roles(pTHX_ const ClassMeta *meta, U32 *nroles)
314 {
315 assert(meta->type == METATYPE_CLASS);
316 AV *roles = meta->cls.direct_roles;
317 *nroles = av_count(roles);
318 return (RoleEmbedding **)AvARRAY(roles);
319 }
320
ObjectPad_mop_class_get_all_roles(pTHX_ const ClassMeta * meta,U32 * nroles)321 RoleEmbedding **ObjectPad_mop_class_get_all_roles(pTHX_ const ClassMeta *meta, U32 *nroles)
322 {
323 assert(meta->type == METATYPE_CLASS);
324 AV *roles = meta->cls.embedded_roles;
325 *nroles = av_count(roles);
326 return (RoleEmbedding **)AvARRAY(roles);
327 }
328
ObjectPad_mop_class_add_method(pTHX_ ClassMeta * meta,SV * methodname)329 MethodMeta *ObjectPad_mop_class_add_method(pTHX_ ClassMeta *meta, SV *methodname)
330 {
331 AV *methods = meta->direct_methods;
332
333 if(meta->sealed)
334 croak("Cannot add a new method to an already-sealed class");
335
336 if(!methodname || !SvOK(methodname) || !SvCUR(methodname))
337 croak("methodname must not be undefined or empty");
338
339 U32 i;
340 for(i = 0; i < av_count(methods); i++) {
341 MethodMeta *methodmeta = (MethodMeta *)AvARRAY(methods)[i];
342 if(sv_eq(methodmeta->name, methodname)) {
343 if(methodmeta->role)
344 croak("Method '%" SVf "' clashes with the one provided by role %" SVf,
345 SVfARG(methodname), SVfARG(methodmeta->role->name));
346 else
347 croak("Cannot add another method named %" SVf, methodname);
348 }
349 }
350
351 MethodMeta *methodmeta;
352 Newx(methodmeta, 1, MethodMeta);
353
354 methodmeta->name = SvREFCNT_inc(methodname);
355 methodmeta->class = meta;
356 methodmeta->role = NULL;
357
358 av_push(methods, (SV *)methodmeta);
359
360 return methodmeta;
361 }
362
ObjectPad_mop_class_add_slot(pTHX_ ClassMeta * meta,SV * slotname)363 SlotMeta *ObjectPad_mop_class_add_slot(pTHX_ ClassMeta *meta, SV *slotname)
364 {
365 AV *slots = meta->direct_slots;
366
367 if(meta->next_slotix == -1)
368 croak("Cannot add a new slot to a class that is not yet begun");
369 if(meta->sealed)
370 croak("Cannot add a new slot to an already-sealed class");
371
372 if(!slotname || !SvOK(slotname) || !SvCUR(slotname))
373 croak("slotname must not be undefined or empty");
374
375 switch(SvPV_nolen(slotname)[0]) {
376 case '$':
377 case '@':
378 case '%':
379 break;
380
381 default:
382 croak("slotname must begin with a sigil");
383 }
384
385 U32 i;
386 for(i = 0; i < av_count(slots); i++) {
387 SlotMeta *slotmeta = (SlotMeta *)AvARRAY(slots)[i];
388 if(SvCUR(slotmeta->name) < 2)
389 continue;
390
391 if(sv_eq(slotmeta->name, slotname))
392 croak("Cannot add another slot named %" SVf, slotname);
393 }
394
395 SlotMeta *slotmeta = mop_create_slot(slotname, meta);
396
397 av_push(slots, (SV *)slotmeta);
398 meta->next_slotix++;
399
400 MOP_CLASS_RUN_HOOKS(meta, post_add_slot, slotmeta);
401
402 return slotmeta;
403 }
404
ObjectPad_mop_class_add_BUILD(pTHX_ ClassMeta * meta,CV * cv)405 void ObjectPad_mop_class_add_BUILD(pTHX_ ClassMeta *meta, CV *cv)
406 {
407 if(meta->sealed)
408 croak("Cannot add a BUILD block to an already-sealed class");
409 if(meta->strict_params)
410 croak("Cannot add a BUILD block to a class with :strict(params)");
411
412 if(!meta->buildblocks)
413 meta->buildblocks = newAV();
414
415 av_push(meta->buildblocks, (SV *)cv);
416 }
417
ObjectPad_mop_class_add_ADJUST(pTHX_ ClassMeta * meta,CV * cv)418 void ObjectPad_mop_class_add_ADJUST(pTHX_ ClassMeta *meta, CV *cv)
419 {
420 if(meta->sealed)
421 croak("Cannot add an ADJUST block to an already-sealed class");
422 if(!meta->adjustblocks)
423 meta->adjustblocks = newAV();
424
425 AdjustBlock *block;
426 Newx(block, 1, struct AdjustBlock);
427
428 block->is_adjustparams = false;
429 block->cv = cv;
430
431 av_push(meta->adjustblocks, (SV *)block);
432 }
433
ObjectPad_mop_class_add_ADJUSTPARAMS(pTHX_ ClassMeta * meta,CV * cv)434 void ObjectPad_mop_class_add_ADJUSTPARAMS(pTHX_ ClassMeta *meta, CV *cv)
435 {
436 if(meta->sealed)
437 croak("Cannot add an ADJUSTPARAMS block to an already-sealed class");
438 if(!meta->adjustblocks)
439 meta->adjustblocks = newAV();
440
441 AdjustBlock *block;
442 Newx(block, 1, struct AdjustBlock);
443
444 block->is_adjustparams = true;
445 block->cv = cv;
446
447 meta->has_adjustparams = true;
448
449 av_push(meta->adjustblocks, (SV *)block);
450 }
451
452 #define mop_class_implements_role(meta, rolemeta) S_mop_class_implements_role(aTHX_ meta, rolemeta)
S_mop_class_implements_role(pTHX_ ClassMeta * meta,ClassMeta * rolemeta)453 static bool S_mop_class_implements_role(pTHX_ ClassMeta *meta, ClassMeta *rolemeta)
454 {
455 U32 i, n;
456 switch(meta->type) {
457 case METATYPE_CLASS: {
458 RoleEmbedding **embeddings = mop_class_get_all_roles(meta, &n);
459 for(i = 0; i < n; i++)
460 if(embeddings[i]->rolemeta == rolemeta)
461 return true;
462
463 break;
464 }
465
466 case METATYPE_ROLE: {
467 ClassMeta **roles = (ClassMeta **)AvARRAY(meta->role.superroles);
468 U32 n = av_count(meta->role.superroles);
469 /* TODO: this isn't super-efficient in deep cross-linked heirarchies */
470 for(i = 0; i < n; i++) {
471 if(roles[i] == rolemeta)
472 return true;
473 if(mop_class_implements_role(roles[i], rolemeta))
474 return true;
475 }
476 break;
477 }
478 }
479
480 return false;
481 }
482
483 #define embed_role(class, role) S_embed_role(aTHX_ class, role)
S_embed_role(pTHX_ ClassMeta * classmeta,ClassMeta * rolemeta)484 static RoleEmbedding *S_embed_role(pTHX_ ClassMeta *classmeta, ClassMeta *rolemeta)
485 {
486 U32 i;
487
488 if(classmeta->type != METATYPE_CLASS)
489 croak("Can only apply to a class");
490 if(rolemeta->type != METATYPE_ROLE)
491 croak("Can only apply a role to a class");
492
493 HV *srcstash = rolemeta->stash;
494 HV *dststash = classmeta->stash;
495
496 SV *embeddingsv = newSV(sizeof(RoleEmbedding));
497 assert(SvTYPE(embeddingsv) == SVt_PV && SvLEN(embeddingsv) >= sizeof(RoleEmbedding));
498
499 RoleEmbedding *embedding = (RoleEmbedding *)SvPVX(embeddingsv);
500
501 embedding->embeddingsv = embeddingsv;
502 embedding->rolemeta = rolemeta;
503 embedding->classmeta = classmeta;
504 embedding->offset = -1;
505
506 av_push(classmeta->cls.embedded_roles, (SV *)embedding);
507 hv_store_ent(rolemeta->role.applied_classes, classmeta->name, (SV *)embedding, 0);
508
509 U32 nbuilds = rolemeta->buildblocks ? av_count(rolemeta->buildblocks) : 0;
510 for(i = 0; i < nbuilds; i++) {
511 CV *buildblock = (CV *)AvARRAY(rolemeta->buildblocks)[i];
512
513 CV *embedded_buildblock = embed_cv(buildblock, embedding);
514
515 if(!classmeta->buildblocks)
516 classmeta->buildblocks = newAV();
517
518 av_push(classmeta->buildblocks, (SV *)embedded_buildblock);
519 }
520
521 U32 nadjusts = rolemeta->adjustblocks ? av_count(rolemeta->adjustblocks) : 0;
522 for(i = 0; i < nadjusts; i++) {
523 AdjustBlock *block = (AdjustBlock *)AvARRAY(rolemeta->adjustblocks)[i];
524
525 CV *embedded_cv = embed_cv(block->cv, embedding);
526
527 if(block->is_adjustparams)
528 mop_class_add_ADJUSTPARAMS(classmeta, embedded_cv);
529 else
530 mop_class_add_ADJUST(classmeta, embedded_cv);
531 }
532
533 if(rolemeta->has_adjustparams)
534 classmeta->has_adjustparams = true;
535
536 U32 nmethods = av_count(rolemeta->direct_methods);
537 for(i = 0; i < nmethods; i++) {
538 MethodMeta *methodmeta = (MethodMeta *)AvARRAY(rolemeta->direct_methods)[i];
539 SV *mname = methodmeta->name;
540
541 HE *he = hv_fetch_ent(srcstash, mname, 0, 0);
542 if(!he || !HeVAL(he) || !GvCV((GV *)HeVAL(he)))
543 croak("ARGH expected to find CODE called %" SVf " in package %" SVf,
544 SVfARG(mname), SVfARG(rolemeta->name));
545
546 {
547 MethodMeta *dstmethodmeta = mop_class_add_method(classmeta, mname);
548 dstmethodmeta->role = rolemeta;
549 }
550
551 GV **gvp = (GV **)hv_fetch(dststash, SvPVX(mname), SvCUR(mname), GV_ADD);
552 gv_init_sv(*gvp, dststash, mname, 0);
553 GvMULTI_on(*gvp);
554
555 if(GvCV(*gvp))
556 croak("Method '%" SVf "' clashes with the one provided by role %" SVf,
557 SVfARG(mname), SVfARG(rolemeta->name));
558
559 CV *newcv;
560 GvCV_set(*gvp, newcv = embed_cv(GvCV((GV *)HeVAL(he)), embedding));
561 CvGV_set(newcv, *gvp);
562 }
563
564 nmethods = av_count(rolemeta->requiremethods);
565 for(i = 0; i < nmethods; i++) {
566 av_push(classmeta->requiremethods, SvREFCNT_inc(AvARRAY(rolemeta->requiremethods)[i]));
567 }
568
569 return embedding;
570 }
571
ObjectPad_mop_class_add_role(pTHX_ ClassMeta * dstmeta,ClassMeta * rolemeta)572 void ObjectPad_mop_class_add_role(pTHX_ ClassMeta *dstmeta, ClassMeta *rolemeta)
573 {
574 if(dstmeta->sealed)
575 croak("Cannot add a role to an already-sealed class");
576 /* Can't currently do this as it breaks t/77mop-create-role.t
577 if(!rolemeta->sealed)
578 croak("Cannot add a role that is not yet sealed");
579 */
580
581 if(mop_class_implements_role(dstmeta, rolemeta))
582 return;
583
584 switch(dstmeta->type) {
585 case METATYPE_CLASS: {
586 U32 nroles;
587 if((nroles = av_count(rolemeta->role.superroles)) > 0) {
588 ClassMeta **roles = (ClassMeta **)AvARRAY(rolemeta->role.superroles);
589 U32 i;
590 for(i = 0; i < nroles; i++)
591 mop_class_add_role(dstmeta, roles[i]);
592 }
593
594 RoleEmbedding *embedding = embed_role(dstmeta, rolemeta);
595 av_push(dstmeta->cls.direct_roles, (SV *)embedding);
596 return;
597 }
598
599 case METATYPE_ROLE:
600 av_push(dstmeta->role.superroles, (SV *)rolemeta);
601 return;
602 }
603 }
604
ObjectPad_mop_class_load_and_add_role(pTHX_ ClassMeta * meta,SV * rolename,SV * rolever)605 void ObjectPad_mop_class_load_and_add_role(pTHX_ ClassMeta *meta, SV *rolename, SV *rolever)
606 {
607 HV *rolestash = gv_stashsv(rolename, 0);
608 if(!rolestash || !hv_fetchs(rolestash, "META", 0)) {
609 /* Try to`require` the module then attempt a second time */
610 load_module(PERL_LOADMOD_NOIMPORT, newSVsv(rolename), NULL, NULL);
611 rolestash = gv_stashsv(rolename, 0);
612 }
613
614 if(!rolestash)
615 croak("Role %" SVf " does not exist", SVfARG(rolename));
616
617 if(rolever && SvOK(rolever))
618 ensure_module_version(rolename, rolever);
619
620 GV **metagvp = (GV **)hv_fetchs(rolestash, "META", 0);
621 ClassMeta *rolemeta = NULL;
622 if(metagvp)
623 rolemeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp))));
624
625 if(!rolemeta || rolemeta->type != METATYPE_ROLE)
626 croak("%" SVf " is not a role", SVfARG(rolename));
627
628 mop_class_add_role(meta, rolemeta);
629 }
630
631 #define embed_slothook(roleh, offset) S_embed_slothook(aTHX_ roleh, offset)
S_embed_slothook(pTHX_ struct SlotHook * roleh,SLOTOFFSET offset)632 static struct SlotHook *S_embed_slothook(pTHX_ struct SlotHook *roleh, SLOTOFFSET offset)
633 {
634 struct SlotHook *classh;
635 Newx(classh, 1, struct SlotHook);
636
637 classh->slotix = roleh->slotix + offset;
638 classh->slotmeta = roleh->slotmeta;
639 classh->funcs = roleh->funcs;
640 classh->hookdata = roleh->hookdata;
641
642 return classh;
643 }
644
645 #define mop_class_apply_role(embedding) S_mop_class_apply_role(aTHX_ embedding)
S_mop_class_apply_role(pTHX_ RoleEmbedding * embedding)646 static void S_mop_class_apply_role(pTHX_ RoleEmbedding *embedding)
647 {
648 ClassMeta *classmeta = embedding->classmeta;
649 ClassMeta *rolemeta = embedding->rolemeta;
650
651 if(classmeta->type != METATYPE_CLASS)
652 croak("Can only apply to a class");
653 if(rolemeta->type != METATYPE_ROLE)
654 croak("Can only apply a role to a class");
655
656 assert(embedding->offset == -1);
657 embedding->offset = classmeta->next_slotix;
658
659 if(rolemeta->parammap) {
660 HV *src = rolemeta->parammap;
661
662 if(!classmeta->parammap)
663 classmeta->parammap = newHV();
664
665 HV *dst = classmeta->parammap;
666
667 hv_iterinit(src);
668
669 HE *iter;
670 while((iter = hv_iternext(src))) {
671 STRLEN klen = HeKLEN(iter);
672 void *key = HeKEY(iter);
673
674 if(klen < 0 ? hv_exists_ent(dst, (SV *)key, HeHASH(iter))
675 : hv_exists(dst, (char *)key, klen))
676 croak("Named parameter '%" SVf "' clashes with the one provided by role %" SVf,
677 SVfARG(HeSVKEY_force(iter)), SVfARG(rolemeta->name));
678
679 ParamMeta *roleparammeta = (ParamMeta *)HeVAL(iter);
680 ParamMeta *classparammeta;
681 Newx(classparammeta, 1, struct ParamMeta);
682
683 classparammeta->slot = roleparammeta->slot;
684 classparammeta->slotix = roleparammeta->slotix + embedding->offset;
685
686 if(klen < 0)
687 hv_store_ent(dst, HeSVKEY(iter), (SV *)classparammeta, HeHASH(iter));
688 else
689 hv_store(dst, HeKEY(iter), klen, (SV *)classparammeta, HeHASH(iter));
690 }
691 }
692
693 if(rolemeta->slothooks_postslots) {
694 if(!classmeta->slothooks_postslots)
695 classmeta->slothooks_postslots = newAV();
696
697 U32 i;
698 for(i = 0; i < av_count(rolemeta->slothooks_postslots); i++) {
699 struct SlotHook *roleh = (struct SlotHook *)AvARRAY(rolemeta->slothooks_postslots)[i];
700 av_push(classmeta->slothooks_postslots, (SV *)embed_slothook(roleh, embedding->offset));
701 }
702 }
703
704 if(rolemeta->slothooks_construct) {
705 if(!classmeta->slothooks_construct)
706 classmeta->slothooks_construct = newAV();
707
708 U32 i;
709 for(i = 0; i < av_count(rolemeta->slothooks_construct); i++) {
710 struct SlotHook *roleh = (struct SlotHook *)AvARRAY(rolemeta->slothooks_construct)[i];
711 av_push(classmeta->slothooks_construct, (SV *)embed_slothook(roleh, embedding->offset));
712 }
713 }
714
715 classmeta->next_slotix += av_count(rolemeta->direct_slots);
716
717 /* TODO: Run an APPLY block if the role has one */
718 }
719
S_apply_roles(pTHX_ ClassMeta * dstmeta,ClassMeta * srcmeta)720 static void S_apply_roles(pTHX_ ClassMeta *dstmeta, ClassMeta *srcmeta)
721 {
722 U32 nroles;
723 RoleEmbedding **arr = mop_class_get_direct_roles(srcmeta, &nroles);
724 U32 i;
725 for(i = 0; i < nroles; i++) {
726 mop_class_apply_role(arr[i]);
727 }
728 }
729
pp_alias_params(pTHX)730 static OP *pp_alias_params(pTHX)
731 {
732 dSP;
733 PADOFFSET padix = PADIX_INITSLOTS_PARAMS;
734
735 SV *params = POPs;
736
737 if(SvTYPE(params) != SVt_PVHV)
738 RETURN;
739
740 SAVESPTR(PAD_SVl(padix));
741 PAD_SVl(padix) = SvREFCNT_inc(params);
742 save_freesv(params);
743
744 RETURN;
745 }
746
pp_croak_from_constructor(pTHX)747 static OP *pp_croak_from_constructor(pTHX)
748 {
749 dSP;
750
751 /* Walk up the caller stack to find the COP of the first caller; i.e. the
752 * first one that wasn't in src/class.c
753 */
754 I32 count = 0;
755 const PERL_CONTEXT *cx;
756 while((cx = caller_cx(count, NULL))) {
757 const char *copfile = CopFILE(cx->blk_oldcop);
758 if(!copfile|| strNE(copfile, "src/class.c")) {
759 PL_curcop = cx->blk_oldcop;
760 break;
761 }
762 count++;
763 }
764
765 croak_sv(POPs);
766 }
767
S_generate_initslots_method(pTHX_ ClassMeta * meta)768 static void S_generate_initslots_method(pTHX_ ClassMeta *meta)
769 {
770 OP *ops = NULL;
771 int i;
772
773 ENTER;
774
775 I32 floor_ix = PL_savestack_ix;
776 {
777 SAVEI32(PL_subline);
778 save_item(PL_subname);
779
780 resume_compcv(&meta->initslots_compcv);
781 }
782
783 SAVEFREESV(PL_compcv);
784
785 I32 save_ix = block_start(TRUE);
786
787 SAVESPTR(PL_curcop);
788 PL_curcop = meta->tmpcop;
789 CopLINE_set(PL_curcop, __LINE__);
790
791 ops = op_append_list(OP_LINESEQ, ops,
792 newSTATEOP(0, NULL, NULL));
793
794 /* A more optimised implementation of this method would be able to generate
795 * a @self lexical and OP_REFASSIGN it, but that would only work on newer
796 * perls. For now we'll take the small performance hit of RV2AV every time
797 */
798
799 enum ReprType repr = meta->repr;
800
801 ops = op_append_list(OP_LINESEQ, ops,
802 newMETHSTARTOP(0 |
803 (meta->type == METATYPE_ROLE ? OPf_SPECIAL : 0) |
804 (repr << 8))
805 );
806
807 ops = op_append_list(OP_LINESEQ, ops,
808 newUNOP_CUSTOM(&pp_alias_params, 0,
809 newOP(OP_SHIFT, OPf_SPECIAL)));
810
811 /* TODO: Icky horrible implementation; if our slotoffset > 0 then
812 * we must be a subclass
813 */
814 if(meta->start_slotix) {
815 struct ClassMeta *supermeta = meta->cls.supermeta;
816
817 assert(supermeta->sealed);
818 assert(supermeta->initslots);
819
820 CopLINE_set(PL_curcop, __LINE__);
821
822 ops = op_append_list(OP_LINESEQ, ops,
823 newSTATEOP(0, NULL, NULL));
824
825 /* Build an OP_ENTERSUB for supermeta's initslots */
826 OP *op = NULL;
827 op = op_append_list(OP_LIST, op,
828 newPADxVOP(OP_PADSV, 0, PADIX_SELF));
829 op = op_append_list(OP_LIST, op,
830 newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITSLOTS_PARAMS));
831 op = op_append_list(OP_LIST, op,
832 newSVOP(OP_CONST, 0, (SV *)supermeta->initslots));
833
834 ops = op_append_list(OP_LINESEQ, ops,
835 op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, op));
836 }
837
838 AV *slots = meta->direct_slots;
839 I32 nslots = av_count(slots);
840
841 {
842 for(i = 0; i < nslots; i++) {
843 SlotMeta *slotmeta = (SlotMeta *)AvARRAY(slots)[i];
844 char sigil = SvPV_nolen(slotmeta->name)[0];
845 OP *op = NULL;
846 SV *defaultsv;
847
848 switch(sigil) {
849 case '$':
850 {
851 CopLINE_set(PL_curcop, __LINE__);
852
853 OP *valueop = NULL;
854
855 if(slotmeta->defaultexpr) {
856 valueop = slotmeta->defaultexpr;
857 }
858 else if((defaultsv = mop_slot_get_default_sv(slotmeta))) {
859 /* An OP_CONST whose op_type is OP_CUSTOM.
860 * This way we avoid the opchecker and finalizer doing bad things
861 * to our defaultsv SV by setting it SvREADONLY_on()
862 */
863 valueop = newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, defaultsv);
864 }
865
866 if(slotmeta->paramname) {
867 SV *paramname = slotmeta->paramname;
868
869 if(!valueop)
870 valueop = newUNOP_CUSTOM(&pp_croak_from_constructor, 0,
871 newSVOP(OP_CONST, 0,
872 newSVpvf("Required parameter '%" SVf "' is missing for %" SVf " constructor",
873 SVfARG(paramname), SVfARG(meta->name))));
874
875 valueop = newCONDOP(0,
876 /* exists $params{$paramname} */
877 newUNOP(OP_EXISTS, 0,
878 newBINOP(OP_HELEM, 0,
879 newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITSLOTS_PARAMS),
880 newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname)))),
881
882 /* ? delete $params{$paramname} */
883 newUNOP(OP_DELETE, 0,
884 newBINOP(OP_HELEM, 0,
885 newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITSLOTS_PARAMS),
886 newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname)))),
887
888 /* : valueop or die */
889 valueop);
890 }
891
892 if(valueop)
893 op = newBINOP(OP_SASSIGN, 0,
894 valueop,
895 /* $slots[$idx] */
896 newAELEMOP(OPf_MOD,
897 newPADxVOP(OP_PADAV, OPf_MOD|OPf_REF, PADIX_SLOTS),
898 slotmeta->slotix));
899 break;
900 }
901 case '@':
902 case '%':
903 {
904 CopLINE_set(PL_curcop, __LINE__);
905
906 OP *valueop = NULL;
907 U16 coerceop = (sigil == '%') ? OP_RV2HV : OP_RV2AV;
908
909 if(slotmeta->defaultexpr) {
910 valueop = slotmeta->defaultexpr;
911 }
912 else if((defaultsv = mop_slot_get_default_sv(slotmeta))) {
913 valueop = newUNOP(coerceop, 0,
914 newSVOP_CUSTOM(PL_ppaddr[OP_CONST], 0, defaultsv));
915 }
916
917 if(valueop) {
918 /* $slots[$idx]->@* or ->%* */
919 OP *lhs = force_list_keeping_pushmark(newUNOP(coerceop, OPf_MOD|OPf_REF,
920 newAELEMOP(0,
921 newPADxVOP(OP_PADAV, OPf_MOD|OPf_REF, PADIX_SLOTS),
922 slotmeta->slotix)));
923
924 op = newBINOP(OP_AASSIGN, 0,
925 force_list_keeping_pushmark(valueop),
926 lhs);
927 }
928 break;
929 }
930
931 default:
932 croak("ARGH: not sure how to handle a slot sigil %c\n", sigil);
933 }
934
935 if(!op)
936 continue;
937
938 /* TODO: grab a COP at the initexpr time */
939 ops = op_append_list(OP_LINESEQ, ops,
940 newSTATEOP(0, NULL, NULL));
941 ops = op_append_list(OP_LINESEQ, ops,
942 op);
943 }
944 }
945
946 if(meta->type == METATYPE_CLASS) {
947 U32 nroles;
948 RoleEmbedding **embeddings = mop_class_get_direct_roles(meta, &nroles);
949
950 for(i = 0; i < nroles; i++) {
951 RoleEmbedding *embedding = embeddings[i];
952 ClassMeta *rolemeta = embedding->rolemeta;
953
954 if(!rolemeta->sealed)
955 mop_class_seal(rolemeta);
956
957 assert(rolemeta->sealed);
958 assert(rolemeta->initslots);
959
960 CopLINE_set(PL_curcop, __LINE__);
961
962 ops = op_append_list(OP_LINESEQ, ops,
963 newSTATEOP(0, NULL, NULL));
964
965 OP *op = NULL;
966 op = op_append_list(OP_LIST, op,
967 newPADxVOP(OP_PADSV, 0, PADIX_SELF));
968 op = op_append_list(OP_LIST, op,
969 newPADxVOP(OP_PADHV, OPf_REF, PADIX_INITSLOTS_PARAMS));
970 op = op_append_list(OP_LIST, op,
971 newSVOP(OP_CONST, 0, (SV *)embed_cv(rolemeta->initslots, embedding)));
972
973 ops = op_append_list(OP_LINESEQ, ops,
974 op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, op));
975 }
976 }
977
978 SvREFCNT_inc(PL_compcv);
979 ops = block_end(save_ix, ops);
980
981 /* newATTRSUB will capture PL_curstash */
982 SAVESPTR(PL_curstash);
983 PL_curstash = meta->stash;
984
985 meta->initslots = newATTRSUB(floor_ix, NULL, NULL, NULL, ops);
986
987 assert(meta->initslots);
988 assert(CvOUTSIDE(meta->initslots));
989
990 LEAVE;
991 }
992
ObjectPad_mop_class_seal(pTHX_ ClassMeta * meta)993 void ObjectPad_mop_class_seal(pTHX_ ClassMeta *meta)
994 {
995 if(meta->sealed) /* idempotent */
996 return;
997
998 if(meta->type == METATYPE_CLASS &&
999 meta->cls.supermeta && !meta->cls.supermeta->sealed) {
1000 /* Must defer sealing until superclass is sealed first
1001 * (RT133190)
1002 */
1003 ClassMeta *supermeta = meta->cls.supermeta;
1004 if(!supermeta->pending_submeta)
1005 supermeta->pending_submeta = newAV();
1006 av_push(supermeta->pending_submeta, (SV *)meta);
1007 return;
1008 }
1009
1010 if(meta->type == METATYPE_CLASS)
1011 S_apply_roles(aTHX_ meta, meta);
1012
1013 if(meta->type == METATYPE_CLASS) {
1014 U32 nmethods = av_count(meta->requiremethods);
1015 U32 i;
1016 for(i = 0; i < nmethods; i++) {
1017 SV *mname = AvARRAY(meta->requiremethods)[i];
1018
1019 GV *gv = gv_fetchmeth_sv(meta->stash, mname, 0, 0);
1020 if(gv && GvCV(gv))
1021 continue;
1022
1023 croak("Class %" SVf " does not provide a required method named '%" SVf "'",
1024 SVfARG(meta->name), SVfARG(mname));
1025 }
1026 }
1027
1028 if(meta->strict_params && meta->buildblocks)
1029 croak("Class %" SVf " cannot be :strict(params) because it has BUILD blocks",
1030 SVfARG(meta->name));
1031
1032 {
1033 U32 i;
1034 for(i = 0; i < av_count(meta->direct_slots); i++) {
1035 SlotMeta *slotmeta = (SlotMeta *)AvARRAY(meta->direct_slots)[i];
1036
1037 U32 hooki;
1038 for(hooki = 0; slotmeta->hooks && hooki < av_count(slotmeta->hooks); hooki++) {
1039 struct SlotHook *h = (struct SlotHook *)AvARRAY(slotmeta->hooks)[hooki];
1040
1041 if(*h->funcs->post_initslot) {
1042 if(!meta->slothooks_postslots)
1043 meta->slothooks_postslots = newAV();
1044
1045 struct SlotHook *fasth;
1046 Newx(fasth, 1, struct SlotHook);
1047
1048 fasth->slotix = slotmeta->slotix;
1049 fasth->slotmeta = slotmeta;
1050 fasth->funcs = h->funcs;
1051 fasth->funcdata = h->funcdata;
1052 fasth->hookdata = h->hookdata;
1053
1054 av_push(meta->slothooks_postslots, (SV *)fasth);
1055 }
1056
1057 if(*h->funcs->post_construct) {
1058 if(!meta->slothooks_construct)
1059 meta->slothooks_construct = newAV();
1060
1061 struct SlotHook *fasth;
1062 Newx(fasth, 1, struct SlotHook);
1063
1064 fasth->slotix = slotmeta->slotix;
1065 fasth->slotmeta = slotmeta;
1066 fasth->funcs = h->funcs;
1067 fasth->funcdata = h->funcdata;
1068 fasth->hookdata = h->hookdata;
1069
1070 av_push(meta->slothooks_construct, (SV *)fasth);
1071 }
1072 }
1073 }
1074 }
1075
1076 S_generate_initslots_method(aTHX_ meta);
1077
1078 meta->sealed = true;
1079
1080 if(meta->pending_submeta) {
1081 int i;
1082 SV **arr = AvARRAY(meta->pending_submeta);
1083 for(i = 0; i < av_count(meta->pending_submeta); i++) {
1084 ClassMeta *submeta = (ClassMeta *)arr[i];
1085 arr[i] = &PL_sv_undef;
1086
1087 mop_class_seal(submeta);
1088 }
1089
1090 SvREFCNT_dec(meta->pending_submeta);
1091 meta->pending_submeta = NULL;
1092 }
1093 }
1094
1095 XS_INTERNAL(injected_constructor);
XS_INTERNAL(injected_constructor)1096 XS_INTERNAL(injected_constructor)
1097 {
1098 dXSARGS;
1099 const ClassMeta *meta = XSANY.any_ptr;
1100 SV *class = ST(0);
1101 SV *self = NULL;
1102
1103 assert(meta->type == METATYPE_CLASS);
1104 if(!meta->sealed)
1105 croak("Cannot yet invoke '%" SVf "' constructor before the class is complete", SVfARG(class));
1106
1107 COP *prevcop = PL_curcop;
1108 PL_curcop = meta->tmpcop;
1109 CopLINE_set(PL_curcop, __LINE__);
1110
1111 /* An AV storing the @_ args to pass to foreign constructor and all the
1112 * build blocks
1113 * This does not include $self
1114 */
1115 AV *args = newAV();
1116 SAVEFREESV(args);
1117
1118 {
1119 /* @args = $class->BUILDARGS(@_) */
1120 ENTER;
1121 SAVETMPS;
1122 SAVEVPTR(PL_curcop);
1123 PL_curcop = prevcop;
1124
1125 /* Splice in an extra copy of `class` so we get one there for the foreign
1126 * constructor */
1127 EXTEND(SP, 1);
1128
1129 SV **argstart = SP - items + 2;
1130 PUSHMARK(argstart - 1);
1131
1132 SV **svp;
1133 for(svp = SP; svp >= argstart; svp--)
1134 *(svp+1) = *svp;
1135 *argstart = class;
1136 SP++;
1137 PUTBACK;
1138
1139 I32 nargs = call_method("BUILDARGS", G_ARRAY);
1140
1141 SPAGAIN;
1142
1143 for(svp = SP - nargs + 1; svp <= SP; svp++)
1144 av_push(args, SvREFCNT_inc(*svp));
1145
1146 FREETMPS;
1147 LEAVE;
1148 }
1149
1150 bool need_makeslots = true;
1151
1152 if(!meta->cls.foreign_new) {
1153 HV *stash = gv_stashsv(class, 0);
1154 if(!stash)
1155 croak("Unable to find stash for class %" SVf, class);
1156
1157 switch(meta->repr) {
1158 case REPR_NATIVE:
1159 case REPR_AUTOSELECT:
1160 CopLINE_set(PL_curcop, __LINE__);
1161 self = sv_2mortal(newRV_noinc((SV *)newAV()));
1162 sv_bless(self, stash);
1163 break;
1164
1165 case REPR_HASH:
1166 CopLINE_set(PL_curcop, __LINE__);
1167 self = sv_2mortal(newRV_noinc((SV *)newHV()));
1168 sv_bless(self, stash);
1169 break;
1170
1171 case REPR_MAGIC:
1172 croak("ARGH cannot use :repr(magic) without a foreign superconstructor");
1173 break;
1174 }
1175 }
1176 else {
1177 CopLINE_set(PL_curcop, __LINE__);
1178
1179 {
1180 ENTER;
1181 SAVETMPS;
1182
1183 PUSHMARK(SP);
1184 EXTEND(SP, 1 + AvFILL(args));
1185
1186 SV **argstart = SP - AvFILL(args) - 1;
1187 SV **argtop = SP;
1188 SV **svp;
1189
1190 mPUSHs(newSVsv(class));
1191
1192 /* Push a copy of the args in case the (foreign) constructor mutates
1193 * them. We still need them for BUILDALL */
1194 for(svp = argstart + 1; svp <= argtop; svp++)
1195 PUSHs(*svp);
1196 PUTBACK;
1197
1198 assert(meta->cls.foreign_new);
1199 call_sv((SV *)meta->cls.foreign_new, G_SCALAR);
1200 SPAGAIN;
1201
1202 self = SvREFCNT_inc(POPs);
1203
1204 PUTBACK;
1205 FREETMPS;
1206 LEAVE;
1207 }
1208
1209 if(!SvROK(self) || !SvOBJECT(SvRV(self))) {
1210 PL_curcop = prevcop;
1211 croak("Expected %" SVf "->SUPER::new to return a blessed reference", class);
1212 }
1213 SV *rv = SvRV(self);
1214
1215 /* It's possible a foreign superclass constructor invoked a `method` and
1216 * thus initslots has already been called. Check here and set
1217 * need_makeslots false if so.
1218 */
1219
1220 switch(meta->repr) {
1221 case REPR_NATIVE:
1222 croak("ARGH shouldn't ever have REPR_NATIVE with foreign_new");
1223
1224 case REPR_HASH:
1225 case_REPR_HASH:
1226 if(SvTYPE(rv) != SVt_PVHV) {
1227 PL_curcop = prevcop;
1228 croak("Expected %" SVf "->SUPER::new to return a blessed HASH reference", class);
1229 }
1230
1231 need_makeslots = !hv_exists(MUTABLE_HV(rv), "Object::Pad/slots", 17);
1232 break;
1233
1234 case REPR_MAGIC:
1235 case_REPR_MAGIC:
1236 /* Anything goes */
1237
1238 need_makeslots = !mg_findext(rv, PERL_MAGIC_ext, &vtbl_slotsav);
1239 break;
1240
1241 case REPR_AUTOSELECT:
1242 if(SvTYPE(rv) == SVt_PVHV)
1243 goto case_REPR_HASH;
1244 goto case_REPR_MAGIC;
1245 }
1246
1247 sv_2mortal(self);
1248 }
1249
1250 AV *slotsav;
1251
1252 if(need_makeslots) {
1253 slotsav = (AV *)get_obj_slotsav(self, meta->repr, TRUE);
1254 make_instance_slots(meta, slotsav, 0);
1255 }
1256 else {
1257 slotsav = (AV *)get_obj_slotsav(self, meta->repr, FALSE);
1258 }
1259
1260 SV **slotsv = AvARRAY(slotsav);
1261
1262 if(meta->slothooks_postslots || meta->slothooks_construct) {
1263 /* We need to set up a fake pad so these hooks can still get PADIX_SELF / PADIX_SLOTS */
1264
1265 /* This MVP is just sufficient enough to let PAD_SVl(PADIX_SELF) work */
1266 SAVEVPTR(PL_curpad);
1267 Newx(PL_curpad, 3, SV *);
1268 SAVEFREEPV(PL_curpad);
1269
1270 PAD_SVl(PADIX_SELF) = self;
1271 PAD_SVl(PADIX_SLOTS) = (SV *)slotsav;
1272 }
1273
1274 if(meta->slothooks_postslots) {
1275 CopLINE_set(PL_curcop, __LINE__);
1276
1277 AV *slothooks = meta->slothooks_postslots;
1278
1279 U32 i;
1280 for(i = 0; i < av_count(slothooks); i++) {
1281 struct SlotHook *h = (struct SlotHook *)AvARRAY(slothooks)[i];
1282 SLOTOFFSET slotix = h->slotix;
1283
1284 (*h->funcs->post_initslot)(aTHX_ h->slotmeta, h->hookdata, h->funcdata, slotsv[slotix]);
1285 }
1286 }
1287
1288 HV *paramhv = NULL;
1289 if(meta->parammap || meta->has_adjustparams) {
1290 paramhv = newHV();
1291 SAVEFREESV((SV *)paramhv);
1292
1293 if(av_count(args) % 2)
1294 warn("Odd-length list passed to %" SVf " constructor", class);
1295
1296 /* TODO: I'm sure there's an newHV_from_AV() around somewhere */
1297 SV **argsv = AvARRAY(args);
1298
1299 IV idx;
1300 for(idx = 0; idx < av_count(args); idx += 2) {
1301 SV *name = argsv[idx];
1302 SV *value = idx < av_count(args)-1 ? argsv[idx+1] : &PL_sv_undef;
1303
1304 hv_store_ent(paramhv, name, SvREFCNT_inc(value), 0);
1305 }
1306 }
1307
1308 {
1309 /* Run initslots */
1310 ENTER;
1311 SAVEVPTR(PL_curcop);
1312 PL_curcop = prevcop;
1313
1314 EXTEND(SP, 2);
1315 PUSHMARK(SP);
1316 PUSHs(self);
1317 if(paramhv)
1318 PUSHs((SV *)paramhv);
1319 else
1320 PUSHs(&PL_sv_undef);
1321 PUTBACK;
1322
1323 assert(meta->initslots);
1324 call_sv((SV *)meta->initslots, G_VOID);
1325
1326 LEAVE;
1327 }
1328
1329 if(meta->buildblocks) {
1330 CopLINE_set(PL_curcop, __LINE__);
1331
1332 AV *buildblocks = meta->buildblocks;
1333 SV **argsvs = AvARRAY(args);
1334 int i;
1335 for(i = 0; i < av_count(buildblocks); i++) {
1336 CV *buildblock = (CV *)AvARRAY(buildblocks)[i];
1337
1338 ENTER;
1339 SAVETMPS;
1340 SPAGAIN;
1341
1342 EXTEND(SP, 1 + AvFILL(args));
1343
1344 PUSHMARK(SP);
1345
1346 PUSHs(self);
1347
1348 int argi;
1349 for(argi = 0; argi <= AvFILL(args); argi++)
1350 PUSHs(argsvs[argi]);
1351 PUTBACK;
1352
1353 assert(buildblock);
1354 call_sv((SV *)buildblock, G_VOID);
1355
1356 FREETMPS;
1357 LEAVE;
1358 }
1359 }
1360
1361 if(meta->adjustblocks) {
1362 CopLINE_set(PL_curcop, __LINE__);
1363
1364 AV *adjustblocks = meta->adjustblocks;
1365 U32 i;
1366 for(i = 0; i < av_count(adjustblocks); i++) {
1367 AdjustBlock *block = (AdjustBlock *)AvARRAY(adjustblocks)[i];
1368
1369 ENTER;
1370 SAVETMPS;
1371 SPAGAIN;
1372
1373 EXTEND(SP, 1 + !!paramhv);
1374
1375 PUSHMARK(SP);
1376 PUSHs(self);
1377 if(paramhv && block->is_adjustparams)
1378 mPUSHs(newRV_inc((SV *)paramhv));
1379 PUTBACK;
1380
1381 assert(block->cv);
1382 call_sv((SV *)block->cv, G_VOID);
1383
1384 FREETMPS;
1385 LEAVE;
1386 }
1387 }
1388
1389 if(paramhv && meta->strict_params && hv_iterinit(paramhv) > 0) {
1390 HE *he = hv_iternext(paramhv);
1391
1392 /* Concat all the param names, in no particular order
1393 * TODO: consider sorting them but that's quite expensive and tricky in XS */
1394
1395 SV *params = newSVsv(HeSVKEY_force(he));
1396 SAVEFREESV(params);
1397
1398 while((he = hv_iternext(paramhv)))
1399 sv_catpvf(params, ", %" SVf, SVfARG(HeSVKEY_force(he)));
1400
1401 PL_curcop = prevcop;
1402 croak("Unrecognised parameters for %" SVf " constructor: %" SVf,
1403 SVfARG(meta->name), SVfARG(params));
1404 }
1405
1406 if(meta->slothooks_construct) {
1407 CopLINE_set(PL_curcop, __LINE__);
1408
1409 AV *slothooks = meta->slothooks_construct;
1410
1411 U32 i;
1412 for(i = 0; i < av_count(slothooks); i++) {
1413 struct SlotHook *h = (struct SlotHook *)AvARRAY(slothooks)[i];
1414 SLOTOFFSET slotix = h->slotix;
1415
1416 (*h->funcs->post_construct)(aTHX_ h->slotmeta, h->hookdata, h->funcdata, slotsv[slotix]);
1417 }
1418 }
1419
1420 PL_curcop = prevcop;
1421 ST(0) = self;
1422 XSRETURN(1);
1423 }
1424
XS_INTERNAL(injected_DOES)1425 XS_INTERNAL(injected_DOES)
1426 {
1427 dXSARGS;
1428 const ClassMeta *meta = XSANY.any_ptr;
1429 SV *self = ST(0);
1430 SV *wantrole = ST(1);
1431
1432 PERL_UNUSED_ARG(items);
1433
1434 CV *cv_does = NULL;
1435
1436 while(meta != NULL) {
1437 AV *roles = meta->type == METATYPE_CLASS ? meta->cls.direct_roles : NULL;
1438 I32 nroles = roles ? av_count(roles) : 0;
1439
1440 if(!cv_does && meta->cls.foreign_does)
1441 cv_does = meta->cls.foreign_does;
1442
1443 if(sv_eq(meta->name, wantrole)) {
1444 XSRETURN_YES;
1445 }
1446
1447 int i;
1448 for(i = 0; i < nroles; i++) {
1449 RoleEmbedding *embedding = (RoleEmbedding *)AvARRAY(roles)[i];
1450 if(sv_eq(embedding->rolemeta->name, wantrole)) {
1451 XSRETURN_YES;
1452 }
1453 }
1454
1455 meta = meta->type == METATYPE_CLASS ? meta->cls.supermeta : NULL;
1456 }
1457
1458 if (cv_does) {
1459 /* return $self->DOES(@_); */
1460 dSP;
1461
1462 ENTER;
1463 SAVETMPS;
1464
1465 PUSHMARK(SP);
1466 EXTEND(SP, 2);
1467 PUSHs(self);
1468 PUSHs(wantrole);
1469 PUTBACK;
1470
1471 int count = call_sv((SV*)cv_does, G_SCALAR);
1472
1473 SPAGAIN;
1474
1475 bool ret = false;
1476
1477 if (count)
1478 ret = POPi;
1479
1480 FREETMPS;
1481 LEAVE;
1482
1483 if(ret)
1484 XSRETURN_YES;
1485 }
1486 else {
1487 /* We need to also respond to Object::Pad::UNIVERSAL and UNIVERSAL */
1488 if(sv_derived_from_sv(self, wantrole, 0))
1489 XSRETURN_YES;
1490 }
1491
1492 XSRETURN_NO;
1493 }
1494
ObjectPad_mop_create_class(pTHX_ enum MetaType type,SV * name)1495 ClassMeta *ObjectPad_mop_create_class(pTHX_ enum MetaType type, SV *name)
1496 {
1497 assert(type == METATYPE_CLASS || type == METATYPE_ROLE);
1498
1499 ClassMeta *meta;
1500 Newx(meta, 1, ClassMeta);
1501
1502 meta->type = type;
1503 meta->name = SvREFCNT_inc(name);
1504
1505 HV *stash = meta->stash = gv_stashsv(name, GV_ADD);
1506
1507 meta->sealed = false;
1508 meta->role_is_invokable = false;
1509 meta->strict_params = false;
1510 meta->has_adjustparams = false;
1511 meta->has_superclass = false;
1512 meta->start_slotix = 0;
1513 meta->next_slotix = -1;
1514 meta->hooks = NULL;
1515 meta->direct_slots = newAV();
1516 meta->direct_methods = newAV();
1517 meta->parammap = NULL;
1518 meta->requiremethods = newAV();
1519 meta->repr = REPR_AUTOSELECT;
1520 meta->pending_submeta = NULL;
1521 meta->buildblocks = NULL;
1522 meta->adjustblocks = NULL;
1523 meta->initslots = NULL;
1524
1525 meta->slothooks_postslots = NULL;
1526 meta->slothooks_construct = NULL;
1527
1528 switch(type) {
1529 case METATYPE_CLASS:
1530 meta->cls.supermeta = NULL;
1531 meta->cls.foreign_new = NULL;
1532 meta->cls.foreign_does = NULL;
1533 meta->cls.direct_roles = newAV();
1534 meta->cls.embedded_roles = newAV();
1535 break;
1536
1537 case METATYPE_ROLE:
1538 meta->role.superroles = newAV();
1539 meta->role.applied_classes = newHV();
1540 break;
1541 }
1542
1543 if(!PL_parser) {
1544 /* We need to generate just enough of a PL_parser to keep newSTATEOP()
1545 * happy, otherwise it will SIGSEGV (RT133258)
1546 */
1547 SAVEVPTR(PL_parser);
1548 Newxz(PL_parser, 1, yy_parser);
1549 SAVEFREEPV(PL_parser);
1550
1551 PL_parser->copline = NOLINE;
1552 #if HAVE_PERL_VERSION(5, 20, 0)
1553 PL_parser->preambling = NOLINE;
1554 #endif
1555 }
1556
1557 /* Prepare meta->initslots for containing a CV parsing operation */
1558 {
1559 if(!PL_compcv) {
1560 /* We require the initslots CV to have a CvOUTSIDE, or else cv_clone()
1561 * will segv when we compose role slots. Any class dynamically generated
1562 * by string eval() will likely not get one, because it won't inherit a
1563 * PL_compcv here. We'll fake it up
1564 * See also https://rt.cpan.org/Ticket/Display.html?id=137952
1565 */
1566 SAVEVPTR(PL_compcv);
1567 PL_compcv = find_runcv(0);
1568
1569 assert(PL_compcv);
1570 }
1571
1572 I32 floor_ix = start_subparse(FALSE, 0);
1573
1574 extend_pad_vars(meta);
1575
1576 /* Skip padix==3 so we're aligned again */
1577 if(meta->type != METATYPE_ROLE)
1578 pad_add_name_pvs("", 0, NULL, NULL);
1579
1580 PADOFFSET padix = pad_add_name_pvs("%params", 0, NULL, NULL);
1581 if(padix != PADIX_INITSLOTS_PARAMS)
1582 croak("ARGH: Expected that padix[%%params] = 4");
1583
1584 intro_my();
1585
1586 suspend_compcv(&meta->initslots_compcv);
1587
1588 LEAVE_SCOPE(floor_ix);
1589 }
1590
1591 meta->tmpcop = (COP *)newSTATEOP(0, NULL, NULL);
1592 CopFILE_set(meta->tmpcop, __FILE__);
1593
1594 meta->methodscope = NULL;
1595
1596 {
1597 /* Inject the constructor */
1598 SV *newname = newSVpvf("%" SVf "::new", name);
1599 SAVEFREESV(newname);
1600
1601 CV *newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, SvFLAGS(newname) & SVf_UTF8);
1602 CvXSUBANY(newcv).any_ptr = meta;
1603 }
1604
1605 {
1606 SV *doesname = newSVpvf("%" SVf "::DOES", name);
1607 SAVEFREESV(doesname);
1608 CV *doescv = newXS_flags(SvPV_nolen(doesname), injected_DOES, __FILE__, NULL, SvFLAGS(doesname) & SVf_UTF8);
1609 CvXSUBANY(doescv).any_ptr = meta;
1610 }
1611
1612 {
1613 GV **gvp = (GV **)hv_fetchs(stash, "META", GV_ADD);
1614 GV *gv = *gvp;
1615 gv_init_pvn(gv, stash, "META", 4, 0);
1616 GvMULTI_on(gv);
1617
1618 SV *sv;
1619 sv_setref_uv(sv = GvSVn(gv), "Object::Pad::MOP::Class", PTR2UV(meta));
1620
1621 newCONSTSUB(meta->stash, "META", sv);
1622 }
1623
1624 return meta;
1625 }
1626
ObjectPad_mop_class_set_superclass(pTHX_ ClassMeta * meta,SV * superclassname)1627 void ObjectPad_mop_class_set_superclass(pTHX_ ClassMeta *meta, SV *superclassname)
1628 {
1629 assert(meta->type == METATYPE_CLASS);
1630
1631 if(meta->has_superclass)
1632 croak("Class already has a superclass, cannot add another");
1633
1634 AV *isa;
1635 {
1636 SV *isaname = newSVpvf("%" SVf "::ISA", meta->name);
1637 SAVEFREESV(isaname);
1638
1639 isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8));
1640 }
1641
1642 av_push(isa, SvREFCNT_inc(superclassname));
1643
1644 ClassMeta *supermeta = NULL;
1645
1646 HV *superstash = gv_stashsv(superclassname, 0);
1647 GV **metagvp = (GV **)hv_fetchs(superstash, "META", 0);
1648 if(metagvp)
1649 supermeta = NUM2PTR(ClassMeta *, SvUV(SvRV(GvSV(*metagvp))));
1650
1651 if(supermeta) {
1652 /* A subclass of an Object::Pad class */
1653 if(supermeta->type != METATYPE_CLASS)
1654 croak("%" SVf " is not a class", SVfARG(superclassname));
1655
1656 /* If it isn't yet sealed (e.g. because we're an inner class of it),
1657 * seal it now
1658 */
1659 if(!supermeta->sealed)
1660 mop_class_seal(supermeta);
1661
1662 meta->start_slotix = supermeta->next_slotix;
1663 meta->repr = supermeta->repr;
1664 meta->cls.foreign_new = supermeta->cls.foreign_new;
1665
1666 if(supermeta->buildblocks) {
1667 if(!meta->buildblocks)
1668 meta->buildblocks = newAV();
1669
1670 av_push_from_av_noinc(meta->buildblocks, supermeta->buildblocks);
1671 }
1672
1673 if(supermeta->adjustblocks) {
1674 if(!meta->adjustblocks)
1675 meta->adjustblocks = newAV();
1676
1677 av_push_from_av_noinc(meta->adjustblocks, supermeta->adjustblocks);
1678 }
1679
1680 if(supermeta->slothooks_postslots) {
1681 if(!meta->slothooks_postslots)
1682 meta->slothooks_postslots = newAV();
1683
1684 av_push_from_av_noinc(meta->slothooks_postslots, supermeta->slothooks_postslots);
1685 }
1686
1687 if(supermeta->slothooks_construct) {
1688 if(!meta->slothooks_construct)
1689 meta->slothooks_construct = newAV();
1690
1691 av_push_from_av_noinc(meta->slothooks_construct, supermeta->slothooks_construct);
1692 }
1693
1694 if(supermeta->parammap) {
1695 HV *old = supermeta->parammap;
1696 HV *new = meta->parammap = newHV();
1697
1698 hv_iterinit(old);
1699
1700 HE *iter;
1701 while((iter = hv_iternext(old))) {
1702 STRLEN klen = HeKLEN(iter);
1703 /* Don't SvREFCNT_inc() the values because they aren't really SV *s */
1704 /* Subclasses *DIRECTLY SHARE* their param metas because the
1705 * information in them is directly compatible
1706 */
1707 if(klen < 0)
1708 hv_store_ent(new, HeSVKEY(iter), HeVAL(iter), HeHASH(iter));
1709 else
1710 hv_store(new, HeKEY(iter), klen, HeVAL(iter), HeHASH(iter));
1711 }
1712 }
1713
1714 if(supermeta->has_adjustparams)
1715 meta->has_adjustparams = true;
1716
1717 U32 nroles;
1718 RoleEmbedding **embeddings = mop_class_get_all_roles(supermeta, &nroles);
1719 if(nroles) {
1720 U32 i;
1721 for(i = 0; i < nroles; i++) {
1722 RoleEmbedding *embedding = embeddings[i];
1723 ClassMeta *rolemeta = embedding->rolemeta;
1724
1725 av_push(meta->cls.embedded_roles, (SV *)embedding);
1726 hv_store_ent(rolemeta->role.applied_classes, meta->name, (SV *)embedding, 0);
1727 }
1728 }
1729 }
1730 else {
1731 /* A subclass of a foreign class */
1732 meta->cls.foreign_new = fetch_superclass_method_pv(meta->stash, "new", 3, -1);
1733 if(!meta->cls.foreign_new)
1734 croak("Unable to find SUPER::new for %" SVf, superclassname);
1735
1736 meta->cls.foreign_does = fetch_superclass_method_pv(meta->stash, "DOES", 4, -1);
1737
1738 av_push(isa, newSVpvs("Object::Pad::UNIVERSAL"));
1739 }
1740
1741 meta->has_superclass = true;
1742 meta->cls.supermeta = supermeta;
1743 }
1744
ObjectPad_mop_class_begin(pTHX_ ClassMeta * meta)1745 void ObjectPad_mop_class_begin(pTHX_ ClassMeta *meta)
1746 {
1747 SV *isaname = newSVpvf("%" SVf "::ISA", meta->name);
1748 SAVEFREESV(isaname);
1749
1750 AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8));
1751 if(!av_count(isa))
1752 av_push(isa, newSVpvs("Object::Pad::UNIVERSAL"));
1753
1754 if(meta->type == METATYPE_CLASS &&
1755 meta->repr == REPR_AUTOSELECT && !meta->cls.foreign_new)
1756 meta->repr = REPR_NATIVE;
1757
1758 meta->next_slotix = meta->start_slotix;
1759 }
1760
1761 /*******************
1762 * Attribute hooks *
1763 *******************/
1764
1765 #ifndef isSPACE_utf8_safe
1766 /* this isn't really safe but it's the best we can do */
1767 # define isSPACE_utf8_safe(p, e) (PERL_UNUSED_ARG(e), isSPACE_utf8(p))
1768 #endif
1769
1770 #define split_package_ver(value, pkgname, pkgversion) S_split_package_ver(aTHX_ value, pkgname, pkgversion)
S_split_package_ver(pTHX_ SV * value,SV * pkgname,SV * pkgversion)1771 static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion)
1772 {
1773 const char *start = SvPVX(value), *p = start, *end = start + SvCUR(value);
1774
1775 while(*p && !isSPACE_utf8_safe(p, end))
1776 p += UTF8SKIP(p);
1777
1778 sv_setpvn(pkgname, start, p - start);
1779 if(SvUTF8(value))
1780 SvUTF8_on(pkgname);
1781
1782 while(*p && isSPACE_utf8_safe(p, end))
1783 p += UTF8SKIP(p);
1784
1785 if(*p) {
1786 /* scan_version() gets upset about trailing content. We need to extract
1787 * exactly what it wants
1788 */
1789 start = p;
1790 if(*p == 'v')
1791 p++;
1792 while(*p && strchr("0123456789._", *p))
1793 p++;
1794 SV *tmpsv = newSVpvn(start, p - start);
1795 SAVEFREESV(tmpsv);
1796
1797 scan_version(SvPVX(tmpsv), pkgversion, FALSE);
1798 }
1799
1800 while(*p && isSPACE_utf8_safe(p, end))
1801 p += UTF8SKIP(p);
1802
1803 return p;
1804 }
1805
1806 /* :isa */
1807
classhook_isa_apply(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)1808 static bool classhook_isa_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
1809 {
1810 SV *superclassname = newSV(0), *superclassver = newSV(0);
1811 SAVEFREESV(superclassname);
1812 SAVEFREESV(superclassver);
1813
1814 const char *end = split_package_ver(value, superclassname, superclassver);
1815
1816 if(*end)
1817 croak("Unexpected characters while parsing :isa() attribute: %s", end);
1818
1819 if(classmeta->type != METATYPE_CLASS)
1820 croak("Only a class may extend another");
1821
1822 HV *superstash = gv_stashsv(superclassname, 0);
1823 if(!superstash || !hv_fetchs(superstash, "new", 0)) {
1824 /* Try to `require` the module then attempt a second time */
1825 /* load_module() will modify the name argument and take ownership of it */
1826 load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL);
1827 superstash = gv_stashsv(superclassname, 0);
1828 }
1829
1830 if(!superstash)
1831 croak("Superclass %" SVf " does not exist", superclassname);
1832
1833 if(superclassver && SvOK(superclassver))
1834 ensure_module_version(superclassname, superclassver);
1835
1836 mop_class_set_superclass(classmeta, superclassname);
1837
1838 return FALSE;
1839 }
1840
1841 static const struct ClassHookFuncs classhooks_isa = {
1842 .ver = OBJECTPAD_ABIVERSION,
1843 .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE,
1844 .apply = &classhook_isa_apply,
1845 };
1846
1847 /* :does */
1848
classhook_does_apply(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)1849 static bool classhook_does_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
1850 {
1851 SV *rolename = newSV(0), *rolever = newSV(0);
1852 SAVEFREESV(rolename);
1853 SAVEFREESV(rolever);
1854
1855 const char *end = split_package_ver(value, rolename, rolever);
1856
1857 if(*end)
1858 croak("Unexpected characters while parsing :does() attribute: %s", end);
1859
1860 mop_class_load_and_add_role(classmeta, rolename, rolever);
1861
1862 return FALSE;
1863 }
1864
1865 static const struct ClassHookFuncs classhooks_does = {
1866 .ver = OBJECTPAD_ABIVERSION,
1867 .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE,
1868 .apply = &classhook_does_apply,
1869 };
1870
1871 /* :repr */
1872
classhook_repr_apply(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)1873 static bool classhook_repr_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
1874 {
1875 char *val = SvPV_nolen(value); /* all comparisons are ASCII */
1876
1877 if(strEQ(val, "native")) {
1878 if(classmeta->type == METATYPE_CLASS && classmeta->cls.foreign_new)
1879 croak("Cannot switch a subclass of a foreign superclass type to :repr(native)");
1880 classmeta->repr = REPR_NATIVE;
1881 }
1882 else if(strEQ(val, "HASH"))
1883 classmeta->repr = REPR_HASH;
1884 else if(strEQ(val, "magic")) {
1885 if(classmeta->type != METATYPE_CLASS || !classmeta->cls.foreign_new)
1886 croak("Cannot switch to :repr(magic) without a foreign superclass");
1887 classmeta->repr = REPR_MAGIC;
1888 }
1889 else if(strEQ(val, "default") || strEQ(val, "autoselect"))
1890 classmeta->repr = REPR_AUTOSELECT;
1891 else
1892 croak("Unrecognised class representation type %" SVf, SVfARG(value));
1893
1894 return FALSE;
1895 }
1896
1897 static const struct ClassHookFuncs classhooks_repr = {
1898 .ver = OBJECTPAD_ABIVERSION,
1899 .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE,
1900 .apply = &classhook_repr_apply,
1901 };
1902
1903 /* :compat */
1904
classhook_compat_apply(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)1905 static bool classhook_compat_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
1906 {
1907 if(strEQ(SvPV_nolen(value), "invokable")) {
1908 if(classmeta->type != METATYPE_ROLE)
1909 croak(":compat(invokable) only applies to a role");
1910
1911 classmeta->role_is_invokable = true;
1912 }
1913 else
1914 croak("Unrecognised class compatibility argument %" SVf, SVfARG(value));
1915
1916 return FALSE;
1917 }
1918
1919 static const struct ClassHookFuncs classhooks_compat = {
1920 .ver = OBJECTPAD_ABIVERSION,
1921 .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE,
1922 .apply = &classhook_compat_apply,
1923 };
1924
1925 /* :strict */
1926
classhook_strict_apply(pTHX_ ClassMeta * classmeta,SV * value,SV ** hookdata_ptr,void * _funcdata)1927 static bool classhook_strict_apply(pTHX_ ClassMeta *classmeta, SV *value, SV **hookdata_ptr, void *_funcdata)
1928 {
1929 if(strEQ(SvPV_nolen(value), "params"))
1930 classmeta->strict_params = TRUE;
1931 else
1932 croak("Unrecognised class strictness type %" SVf, SVfARG(value));
1933
1934 return FALSE;
1935 }
1936
1937 static const struct ClassHookFuncs classhooks_strict = {
1938 .ver = OBJECTPAD_ABIVERSION,
1939 .flags = OBJECTPAD_FLAG_ATTR_MUST_VALUE,
1940 .apply = &classhook_strict_apply,
1941 };
1942
ObjectPad__boot_classes(void)1943 void ObjectPad__boot_classes(void)
1944 {
1945 register_class_attribute("isa", &classhooks_isa, NULL);
1946 register_class_attribute("does", &classhooks_does, NULL);
1947 register_class_attribute("repr", &classhooks_repr, NULL);
1948 register_class_attribute("compat", &classhooks_compat, NULL);
1949 register_class_attribute("strict", &classhooks_strict, NULL);
1950 }
1951