1 /* class.c
2 *
3 * Copyright (C) 2022 by Paul Evans and others
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10 /* This file contains the code that implements perl's new `use feature 'class'`
11 * object model
12 */
13
14 #include "EXTERN.h"
15 #define PERL_IN_CLASS_C
16 #include "perl.h"
17
18 #include "XSUB.h"
19
20 enum {
21 PADIX_SELF = 1,
22 PADIX_PARAMS = 2,
23 };
24
25 void
Perl_croak_kw_unless_class(pTHX_ const char * kw)26 Perl_croak_kw_unless_class(pTHX_ const char *kw)
27 {
28 PERL_ARGS_ASSERT_CROAK_KW_UNLESS_CLASS;
29
30 if(!HvSTASH_IS_CLASS(PL_curstash))
31 croak("Cannot '%s' outside of a 'class'", kw);
32 }
33
34 #define newSVobject(fieldcount) Perl_newSVobject(aTHX_ fieldcount)
35 SV *
Perl_newSVobject(pTHX_ Size_t fieldcount)36 Perl_newSVobject(pTHX_ Size_t fieldcount)
37 {
38 SV *sv = newSV_type(SVt_PVOBJ);
39
40 Newx(ObjectFIELDS(sv), fieldcount, SV *);
41 ObjectMAXFIELD(sv) = fieldcount - 1;
42
43 Zero(ObjectFIELDS(sv), fieldcount, SV *);
44
45 return sv;
46 }
47
PP(pp_initfield)48 PP(pp_initfield)
49 {
50 dSP;
51 UNOP_AUX_item *aux = cUNOP_AUX->op_aux;
52
53 SV *self = PAD_SVl(PADIX_SELF);
54 assert(SvTYPE(SvRV(self)) == SVt_PVOBJ);
55 SV *instance = SvRV(self);
56
57 SV **fields = ObjectFIELDS(instance);
58
59 PADOFFSET fieldix = aux[0].uv;
60
61 SV *val = NULL;
62
63 switch(PL_op->op_private & (OPpINITFIELD_AV|OPpINITFIELD_HV)) {
64 case 0:
65 if(PL_op->op_flags & OPf_STACKED)
66 val = newSVsv(POPs);
67 else
68 val = newSV(0);
69 break;
70
71 case OPpINITFIELD_AV:
72 {
73 AV *av;
74 if(PL_op->op_flags & OPf_STACKED) {
75 SV **svp = PL_stack_base + POPMARK + 1;
76 STRLEN count = SP - svp + 1;
77
78 av = newAV_alloc_x(count);
79
80 av_extend(av, count);
81 while(svp <= SP) {
82 av_push_simple(av, newSVsv(*svp));
83 svp++;
84 }
85 }
86 else
87 av = newAV();
88 val = (SV *)av;
89 break;
90 }
91
92 case OPpINITFIELD_HV:
93 {
94 HV *hv = newHV();
95 if(PL_op->op_flags & OPf_STACKED) {
96 SV **svp = PL_stack_base + POPMARK + 1;
97 STRLEN svcount = SP - svp + 1;
98
99 if(svcount % 2)
100 Perl_warner(aTHX_
101 packWARN(WARN_MISC), "Odd number of elements in hash field initialization");
102
103 while(svp <= SP) {
104 SV *key = *svp; svp++;
105 SV *val = svp <= SP ? *svp : &PL_sv_undef; svp++;
106
107 (void)hv_store_ent(hv, key, newSVsv(val), 0);
108 }
109 }
110 val = (SV *)hv;
111 break;
112 }
113 }
114
115 fields[fieldix] = val;
116
117 PADOFFSET padix = PL_op->op_targ;
118 if(padix) {
119 SAVESPTR(PAD_SVl(padix));
120 SV *sv = PAD_SVl(padix) = SvREFCNT_inc(val);
121 save_freesv(sv);
122 }
123
124 RETURN;
125 }
126
127 XS(injected_constructor);
XS(injected_constructor)128 XS(injected_constructor)
129 {
130 dXSARGS;
131
132 HV *stash = (HV *)XSANY.any_sv;
133 assert(HvSTASH_IS_CLASS(stash));
134
135 struct xpvhv_aux *aux = HvAUX(stash);
136
137 if((items - 1) % 2)
138 Perl_warn(aTHX_ "Odd number of arguments passed to %" HvNAMEf_QUOTEDPREFIX " constructor",
139 HvNAMEfARG(stash));
140
141 HV *params = NULL;
142 {
143 /* Set up params HV */
144 params = newHV();
145 SAVEFREESV((SV *)params);
146
147 for(I32 i = 1; i < items; i += 2) {
148 SV *name = ST(i);
149 SV *val = (i+1 < items) ? ST(i+1) : &PL_sv_undef;
150
151 /* TODO: think about sanity-checking name for being
152 * defined
153 * not ref (but overloaded objects?? boo)
154 * not duplicate
155 * But then, %params = @_; wouldn't do that
156 */
157
158 (void)hv_store_ent(params, name, SvREFCNT_inc(val), 0);
159 }
160 }
161
162 SV *instance = newSVobject(aux->xhv_class_next_fieldix);
163 SvOBJECT_on(instance);
164 SvSTASH_set(instance, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
165
166 SV *self = sv_2mortal(newRV_noinc(instance));
167
168 assert(aux->xhv_class_initfields_cv);
169 {
170 ENTER;
171 SAVETMPS;
172
173 EXTEND(SP, 2);
174 PUSHMARK(SP);
175 PUSHs(self);
176 if(params)
177 PUSHs((SV *)params); // yes a raw HV
178 else
179 PUSHs(&PL_sv_undef);
180 PUTBACK;
181
182 call_sv((SV *)aux->xhv_class_initfields_cv, G_VOID);
183
184 SPAGAIN;
185
186 FREETMPS;
187 LEAVE;
188 }
189
190 if(aux->xhv_class_adjust_blocks) {
191 CV **cvp = (CV **)AvARRAY(aux->xhv_class_adjust_blocks);
192 U32 nblocks = av_count(aux->xhv_class_adjust_blocks);
193
194 for(U32 i = 0; i < nblocks; i++) {
195 ENTER;
196 SAVETMPS;
197 SPAGAIN;
198
199 EXTEND(SP, 2);
200
201 PUSHMARK(SP);
202 PUSHs(self); /* I don't believe this needs to be an sv_mortalcopy() */
203 PUTBACK;
204
205 call_sv((SV *)cvp[i], G_VOID);
206
207 SPAGAIN;
208
209 FREETMPS;
210 LEAVE;
211 }
212 }
213
214 if(params && hv_iterinit(params) > 0) {
215 /* TODO: consider sorting these into a canonical order, but that's awkward */
216 HE *he = hv_iternext(params);
217
218 SV *paramnames = newSVsv(HeSVKEY_force(he));
219 SAVEFREESV(paramnames);
220
221 while((he = hv_iternext(params)))
222 Perl_sv_catpvf(aTHX_ paramnames, ", %" SVf, SVfARG(HeSVKEY_force(he)));
223
224 croak("Unrecognised parameters for %" HvNAMEf_QUOTEDPREFIX " constructor: %" SVf,
225 HvNAMEfARG(stash), SVfARG(paramnames));
226 }
227
228 EXTEND(SP, 1);
229 ST(0) = self;
230 XSRETURN(1);
231 }
232
233 /* OP_METHSTART is an UNOP_AUX whose AUX list contains
234 * [0].uv = count of fieldbinding pairs
235 * [1].uv = maximum fieldidx found in the binding list
236 * [...] = pairs of (padix, fieldix) to bind in .uv fields
237 */
238
239 /* TODO: People would probably expect to find this in pp.c ;) */
PP(pp_methstart)240 PP(pp_methstart)
241 {
242 SV *self = av_shift(GvAV(PL_defgv));
243 SV *rv = NULL;
244
245 /* pp_methstart happens before the first OP_NEXTSTATE of the method body,
246 * meaning PL_curcop still points at the callsite. This is useful for
247 * croak() messages. However, it means we have to find our current stash
248 * via a different technique.
249 */
250 CV *curcv;
251 if(LIKELY(CxTYPE(CX_CUR()) == CXt_SUB))
252 curcv = CX_CUR()->blk_sub.cv;
253 else
254 curcv = find_runcv(NULL);
255
256 if(!SvROK(self) ||
257 !SvOBJECT((rv = SvRV(self))) ||
258 SvTYPE(rv) != SVt_PVOBJ) {
259 HEK *namehek = CvGvNAME_HEK(curcv);
260 croak(
261 namehek ? "Cannot invoke method %" HEKf_QUOTEDPREFIX " on a non-instance" :
262 "Cannot invoke method on a non-instance",
263 namehek);
264 }
265
266 if(CvSTASH(curcv) != SvSTASH(rv) &&
267 !sv_derived_from_hv(self, CvSTASH(curcv)))
268 croak("Cannot invoke a method of %" HvNAMEf_QUOTEDPREFIX " on an instance of %" HvNAMEf_QUOTEDPREFIX,
269 HvNAMEfARG(CvSTASH(curcv)), HvNAMEfARG(SvSTASH(rv)));
270
271 save_clearsv(&PAD_SVl(PADIX_SELF));
272 sv_setsv(PAD_SVl(PADIX_SELF), self);
273
274 UNOP_AUX_item *aux = cUNOP_AUX->op_aux;
275 if(aux) {
276 assert(SvTYPE(SvRV(self)) == SVt_PVOBJ);
277 SV *instance = SvRV(self);
278 SV **fieldp = ObjectFIELDS(instance);
279
280 U32 fieldcount = (aux++)->uv;
281 U32 max_fieldix = (aux++)->uv;
282
283 assert((U32)(ObjectMAXFIELD(instance)+1) > max_fieldix);
284 PERL_UNUSED_VAR(max_fieldix);
285
286 for(Size_t i = 0; i < fieldcount; i++) {
287 PADOFFSET padix = (aux++)->uv;
288 U32 fieldix = (aux++)->uv;
289
290 assert(fieldp[fieldix]);
291
292 /* TODO: There isn't a convenient SAVE macro for doing both these
293 * steps in one go. Add one. */
294 SAVESPTR(PAD_SVl(padix));
295 SV *sv = PAD_SVl(padix) = SvREFCNT_inc(fieldp[fieldix]);
296 save_freesv(sv);
297 }
298 }
299
300 if(PL_op->op_private & OPpINITFIELDS) {
301 SV *params = *av_fetch(GvAV(PL_defgv), 0, 0);
302 if(params && SvTYPE(params) == SVt_PVHV) {
303 SAVESPTR(PAD_SVl(PADIX_PARAMS));
304 PAD_SVl(PADIX_PARAMS) = SvREFCNT_inc(params);
305 save_freesv(params);
306 }
307 }
308
309 return NORMAL;
310 }
311
312 static void
invoke_class_seal(pTHX_ void * _arg)313 invoke_class_seal(pTHX_ void *_arg)
314 {
315 class_seal_stash((HV *)_arg);
316 }
317
318 void
Perl_class_setup_stash(pTHX_ HV * stash)319 Perl_class_setup_stash(pTHX_ HV *stash)
320 {
321 PERL_ARGS_ASSERT_CLASS_SETUP_STASH;
322
323 assert(HvHasAUX(stash));
324
325 if(HvSTASH_IS_CLASS(stash)) {
326 croak("Cannot reopen existing class %" HvNAMEf_QUOTEDPREFIX,
327 HvNAMEfARG(stash));
328 }
329
330 {
331 SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash));
332 sv_2mortal(isaname);
333
334 AV *isa = get_av(SvPV_nolen(isaname), (SvFLAGS(isaname) & SVf_UTF8));
335
336 if(isa && av_count(isa) > 0)
337 croak("Cannot create class %" HEKf " as it already has a non-empty @ISA",
338 HvNAME_HEK(stash));
339 }
340
341 char *classname = HvNAME(stash);
342 U32 nameflags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0;
343
344 /* TODO:
345 * Set some kind of flag on the stash to point out it's a class
346 * Allocate storage for all the extra things a class needs
347 * See https://github.com/leonerd/perl5/discussions/1
348 */
349
350 /* Inject the constructor */
351 {
352 SV *newname = Perl_newSVpvf(aTHX_ "%s::new", classname);
353 SAVEFREESV(newname);
354
355 CV *newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, nameflags);
356 CvXSUBANY(newcv).any_sv = (SV *)stash;
357 CvREFCOUNTED_ANYSV_on(newcv);
358 }
359
360 /* TODO:
361 * DOES method
362 */
363
364 struct xpvhv_aux *aux = HvAUX(stash);
365 aux->xhv_class_superclass = NULL;
366 aux->xhv_class_initfields_cv = NULL;
367 aux->xhv_class_adjust_blocks = NULL;
368 aux->xhv_class_fields = NULL;
369 aux->xhv_class_next_fieldix = 0;
370 aux->xhv_class_param_map = NULL;
371
372 aux->xhv_aux_flags |= HvAUXf_IS_CLASS;
373
374 SAVEDESTRUCTOR_X(invoke_class_seal, stash);
375
376 /* Prepare a suspended compcv for parsing field init expressions */
377 {
378 I32 floor_ix = start_subparse(FALSE, 0);
379
380 CvIsMETHOD_on(PL_compcv);
381
382 /* We don't want to make `$self` visible during the expression but we
383 * still need to give it a name. Make it unusable from pure perl
384 */
385 PADOFFSET padix = pad_add_name_pvs("$(self)", 0, NULL, NULL);
386 assert(padix == PADIX_SELF);
387
388 padix = pad_add_name_pvs("%(params)", 0, NULL, NULL);
389 assert(padix == PADIX_PARAMS);
390
391 PERL_UNUSED_VAR(padix);
392
393 Newx(aux->xhv_class_suspended_initfields_compcv, 1, struct suspended_compcv);
394 suspend_compcv(aux->xhv_class_suspended_initfields_compcv);
395
396 LEAVE_SCOPE(floor_ix);
397 }
398 }
399
400 #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)401 static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion)
402 {
403 const char *start = SvPVX(value),
404 *p = start,
405 *end = start + SvCUR(value);
406
407 while(*p && !isSPACE_utf8_safe(p, end))
408 p += UTF8SKIP(p);
409
410 sv_setpvn(pkgname, start, p - start);
411 if(SvUTF8(value))
412 SvUTF8_on(pkgname);
413
414 while(*p && isSPACE_utf8_safe(p, end))
415 p += UTF8SKIP(p);
416
417 if(*p) {
418 /* scan_version() gets upset about trailing content. We need to extract
419 * exactly what it wants
420 */
421 start = p;
422 if(*p == 'v')
423 p++;
424 while(*p && strchr("0123456789._", *p))
425 p++;
426 SV *tmpsv = newSVpvn(start, p - start);
427 SAVEFREESV(tmpsv);
428
429 scan_version(SvPVX(tmpsv), pkgversion, FALSE);
430 }
431
432 while(*p && isSPACE_utf8_safe(p, end))
433 p += UTF8SKIP(p);
434
435 return p;
436 }
437
438 #define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version)
S_ensure_module_version(pTHX_ SV * module,SV * version)439 static void S_ensure_module_version(pTHX_ SV *module, SV *version)
440 {
441 dSP;
442
443 ENTER;
444
445 PUSHMARK(SP);
446 PUSHs(module);
447 PUSHs(version);
448 PUTBACK;
449
450 call_method("VERSION", G_VOID);
451
452 LEAVE;
453 }
454
455 #define split_attr_nameval(sv, namp, valp) S_split_attr_nameval(aTHX_ sv, namp, valp)
S_split_attr_nameval(pTHX_ SV * sv,SV ** namp,SV ** valp)456 static void S_split_attr_nameval(pTHX_ SV *sv, SV **namp, SV **valp)
457 {
458 STRLEN svlen = SvCUR(sv);
459 bool do_utf8 = SvUTF8(sv);
460
461 const char *paren_at = (const char *)memchr(SvPVX(sv), '(', svlen);
462 if(paren_at) {
463 STRLEN namelen = paren_at - SvPVX(sv);
464
465 if(SvPVX(sv)[svlen-1] != ')')
466 /* Should be impossible to reach this by parsing regular perl code
467 * by as class_apply_attributes() is XS-visible API it might still
468 * be reachable. As it's likely unreachable by normal perl code,
469 * don't bother listing it in perldiag.
470 */
471 /* diag_listed_as: SKIPME */
472 croak("Malformed attribute string");
473 *namp = sv_2mortal(newSVpvn_utf8(SvPVX(sv), namelen, do_utf8));
474
475 const char *value_at = paren_at + 1;
476 const char *value_max = SvPVX(sv) + svlen - 2;
477
478 /* TODO: We're only obeying ASCII whitespace here */
479
480 /* Trim whitespace at the start */
481 while(value_at < value_max && isSPACE(*value_at))
482 value_at += 1;
483 while(value_max > value_at && isSPACE(*value_max))
484 value_max -= 1;
485
486 if(value_max >= value_at)
487 *valp = sv_2mortal(newSVpvn_utf8(value_at, value_max - value_at + 1, do_utf8));
488 }
489 else {
490 *namp = sv;
491 *valp = NULL;
492 }
493 }
494
495 static void
apply_class_attribute_isa(pTHX_ HV * stash,SV * value)496 apply_class_attribute_isa(pTHX_ HV *stash, SV *value)
497 {
498 assert(HvSTASH_IS_CLASS(stash));
499 struct xpvhv_aux *aux = HvAUX(stash);
500
501 /* Parse `value` into name + version */
502 SV *superclassname = sv_newmortal(), *superclassver = sv_newmortal();
503 const char *end = split_package_ver(value, superclassname, superclassver);
504 if(*end)
505 croak("Unexpected characters while parsing class :isa attribute: %s", end);
506
507 if(aux->xhv_class_superclass)
508 croak("Class already has a superclass, cannot add another");
509
510 HV *superstash = gv_stashsv(superclassname, 0);
511 if(!superstash) {
512 /* Try to `require` the module then attempt a second time */
513 load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL);
514 superstash = gv_stashsv(superclassname, 0);
515 }
516 if(!superstash || !HvSTASH_IS_CLASS(superstash))
517 /* TODO: This would be a useful feature addition */
518 croak("Class :isa attribute requires a class but %" HvNAMEf_QUOTEDPREFIX " is not one",
519 HvNAMEfARG(superstash));
520
521 if(superclassver && SvOK(superclassver))
522 ensure_module_version(superclassname, superclassver);
523
524 /* TODO: Suuuurely there's a way to fetch this neatly with stash + "ISA"
525 * You'd think that GvAV() of hv_fetchs() would do it, but no, because it
526 * won't lazily create a proper (magical) GV if one didn't already exist.
527 */
528 {
529 SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash));
530 sv_2mortal(isaname);
531
532 AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8));
533
534 ENTER;
535
536 /* Temporarily remove the SVf_READONLY flag */
537 SAVESETSVFLAGS((SV *)isa, SVf_READONLY|SVf_PROTECT, SVf_READONLY|SVf_PROTECT);
538 SvREADONLY_off((SV *)isa);
539
540 av_push(isa, newSVsv(value));
541
542 LEAVE;
543 }
544
545 aux->xhv_class_superclass = (HV *)SvREFCNT_inc(superstash);
546
547 struct xpvhv_aux *superaux = HvAUX(superstash);
548
549 aux->xhv_class_next_fieldix = superaux->xhv_class_next_fieldix;
550
551 if(superaux->xhv_class_adjust_blocks) {
552 if(!aux->xhv_class_adjust_blocks)
553 aux->xhv_class_adjust_blocks = newAV();
554
555 for(SSize_t i = 0; i <= AvFILL(superaux->xhv_class_adjust_blocks); i++)
556 av_push(aux->xhv_class_adjust_blocks, AvARRAY(superaux->xhv_class_adjust_blocks)[i]);
557 }
558
559 if(superaux->xhv_class_param_map) {
560 aux->xhv_class_param_map = newHVhv(superaux->xhv_class_param_map);
561 }
562 }
563
564 static struct {
565 const char *name;
566 bool requires_value;
567 void (*apply)(pTHX_ HV *stash, SV *value);
568 } const class_attributes[] = {
569 { .name = "isa",
570 .requires_value = true,
571 .apply = &apply_class_attribute_isa,
572 },
573 {0}
574 };
575
576 static void
S_class_apply_attribute(pTHX_ HV * stash,OP * attr)577 S_class_apply_attribute(pTHX_ HV *stash, OP *attr)
578 {
579 assert(attr->op_type == OP_CONST);
580
581 SV *name, *value;
582 split_attr_nameval(cSVOPx_sv(attr), &name, &value);
583
584 for(int i = 0; class_attributes[i].name; i++) {
585 /* TODO: These attribute names are not UTF-8 aware */
586 if(!strEQ(SvPVX(name), class_attributes[i].name))
587 continue;
588
589 if(class_attributes[i].requires_value && !(value && SvOK(value)))
590 croak("Class attribute %" SVf " requires a value", SVfARG(name));
591
592 (*class_attributes[i].apply)(aTHX_ stash, value);
593 return;
594 }
595
596 croak("Unrecognized class attribute %" SVf, SVfARG(name));
597 }
598
599 void
Perl_class_apply_attributes(pTHX_ HV * stash,OP * attrlist)600 Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist)
601 {
602 PERL_ARGS_ASSERT_CLASS_APPLY_ATTRIBUTES;
603
604 if(!attrlist)
605 return;
606 if(attrlist->op_type == OP_NULL) {
607 op_free(attrlist);
608 return;
609 }
610
611 if(attrlist->op_type == OP_LIST) {
612 OP *o = cLISTOPx(attrlist)->op_first;
613 assert(o->op_type == OP_PUSHMARK);
614 o = OpSIBLING(o);
615
616 for(; o; o = OpSIBLING(o))
617 S_class_apply_attribute(aTHX_ stash, o);
618 }
619 else
620 S_class_apply_attribute(aTHX_ stash, attrlist);
621
622 op_free(attrlist);
623 }
624
625 static OP *
S_newCROAKOP(pTHX_ SV * message)626 S_newCROAKOP(pTHX_ SV *message)
627 {
628 OP *o = newLISTOP(OP_LIST, 0,
629 newOP(OP_PUSHMARK, 0),
630 newSVOP(OP_CONST, 0, message));
631 return op_convert_list(OP_DIE, 0, o);
632 }
633 #define newCROAKOP(message) S_newCROAKOP(aTHX_ message)
634
635 void
Perl_class_seal_stash(pTHX_ HV * stash)636 Perl_class_seal_stash(pTHX_ HV *stash)
637 {
638 PERL_ARGS_ASSERT_CLASS_SEAL_STASH;
639
640 assert(HvSTASH_IS_CLASS(stash));
641 struct xpvhv_aux *aux = HvAUX(stash);
642
643 /* generate initfields CV */
644 {
645 I32 floor_ix = PL_savestack_ix;
646 SAVEI32(PL_subline);
647 save_item(PL_subname);
648
649 resume_compcv_final(aux->xhv_class_suspended_initfields_compcv);
650
651 /* Some OP_INITFIELD ops will need to populate the pad with their
652 * result because later ops will rely on it. There's no need to do
653 * this for every op though. Store a mapping to work out which ones
654 * we'll need.
655 */
656 PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv));
657 HV *fieldix_to_padix = newHV();
658 SAVEFREESV((SV *)fieldix_to_padix);
659
660 /* padix 0 == @_; padix 1 == $self. Start at 2 */
661 for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) {
662 PADNAME *pn = PadnamelistARRAY(pnl)[padix];
663 if(!pn || !PadnameIsFIELD(pn))
664 continue;
665
666 U32 fieldix = PadnameFIELDINFO(pn)->fieldix;
667 (void)hv_store_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), newSVuv(padix), 0);
668 }
669
670 OP *ops = NULL;
671
672 ops = op_append_list(OP_LINESEQ, ops,
673 newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL));
674
675 if(aux->xhv_class_superclass) {
676 HV *superstash = aux->xhv_class_superclass;
677 assert(HvSTASH_IS_CLASS(superstash));
678 struct xpvhv_aux *superaux = HvAUX(superstash);
679
680 /* Build an OP_ENTERSUB */
681 OP *o = NULL;
682 o = op_append_list(OP_LIST, o,
683 newPADxVOP(OP_PADSV, 0, PADIX_SELF));
684 o = op_append_list(OP_LIST, o,
685 newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS));
686 /* TODO: This won't work at all well under `use threads` because
687 * it embeds the CV * to the superclass initfields CV right into
688 * the optree. Maybe we'll have to pop it in the pad or something
689 */
690 o = op_append_list(OP_LIST, o,
691 newSVOP(OP_CONST, 0, (SV *)superaux->xhv_class_initfields_cv));
692
693 ops = op_append_list(OP_LINESEQ, ops,
694 op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, o));
695 }
696
697 PADNAMELIST *fieldnames = aux->xhv_class_fields;
698
699 for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) {
700 PADNAME *pn = PadnamelistARRAY(fieldnames)[i];
701 char sigil = PadnamePV(pn)[0];
702 PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix;
703
704 /* Extract the OP_{NEXT,DB}STATE op from the defop so we can
705 * splice it in
706 */
707 OP *valop = PadnameFIELDINFO(pn)->defop;
708 if(valop && valop->op_type == OP_LINESEQ) {
709 OP *o = cLISTOPx(valop)->op_first;
710 cLISTOPx(valop)->op_first = NULL;
711 cLISTOPx(valop)->op_last = NULL;
712 /* have to clear the OPf_KIDS flag or op_free() will get upset */
713 valop->op_flags &= ~OPf_KIDS;
714 op_free(valop);
715 assert(valop->op_type == OP_FREED);
716
717 OP *fieldcop = o;
718 assert(fieldcop->op_type == OP_NEXTSTATE || fieldcop->op_type == OP_DBSTATE);
719 o = OpSIBLING(o);
720 OpLASTSIB_set(fieldcop, NULL);
721
722 valop = o;
723 OpLASTSIB_set(valop, NULL);
724
725 ops = op_append_list(OP_LINESEQ, ops, fieldcop);
726 }
727
728 SV *paramname = PadnameFIELDINFO(pn)->paramname;
729
730 U8 op_priv = 0;
731 switch(sigil) {
732 case '$':
733 if(paramname) {
734 if(!valop)
735 valop = newCROAKOP(
736 newSVpvf("Required parameter '%" SVf "' is missing for %" HvNAMEf_QUOTEDPREFIX " constructor",
737 SVfARG(paramname), HvNAMEfARG(stash))
738 );
739
740 OP *helemop =
741 newBINOP(OP_HELEM, 0,
742 newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS),
743 newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname)));
744
745 if(PadnameFIELDINFO(pn)->def_if_undef) {
746 /* delete $params{$paramname} // DEFOP */
747 valop = newLOGOP(OP_DOR, 0,
748 newUNOP(OP_DELETE, 0, helemop), valop);
749 }
750 else if(PadnameFIELDINFO(pn)->def_if_false) {
751 /* delete $params{$paramname} || DEFOP */
752 valop = newLOGOP(OP_OR, 0,
753 newUNOP(OP_DELETE, 0, helemop), valop);
754 }
755 else {
756 /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */
757 /* more efficient with the new OP_HELEMEXISTSOR */
758 valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8,
759 helemop, valop);
760 }
761
762 valop = op_contextualize(valop, G_SCALAR);
763 }
764 break;
765
766 case '@':
767 op_priv = OPpINITFIELD_AV;
768 break;
769
770 case '%':
771 op_priv = OPpINITFIELD_HV;
772 break;
773
774 default:
775 NOT_REACHED;
776 }
777
778 UNOP_AUX_item *aux;
779 Newx(aux, 2, UNOP_AUX_item);
780
781 aux[0].uv = fieldix;
782
783 OP *fieldop = newUNOP_AUX(OP_INITFIELD, valop ? OPf_STACKED : 0, valop, aux);
784 fieldop->op_private = op_priv;
785
786 HE *he;
787 if((he = hv_fetch_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), 0, 0)) &&
788 SvOK(HeVAL(he))) {
789 fieldop->op_targ = SvUV(HeVAL(he));
790 }
791
792 ops = op_append_list(OP_LINESEQ, ops, fieldop);
793 }
794
795 /* initfields CV should not get class_wrap_method_body() called on its
796 * body. pretend it isn't a method for now */
797 CvIsMETHOD_off(PL_compcv);
798 CV *initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops);
799 CvIsMETHOD_on(initfields);
800
801 aux->xhv_class_initfields_cv = initfields;
802 }
803 }
804
805 void
Perl_class_prepare_initfield_parse(pTHX)806 Perl_class_prepare_initfield_parse(pTHX)
807 {
808 PERL_ARGS_ASSERT_CLASS_PREPARE_INITFIELD_PARSE;
809
810 assert(HvSTASH_IS_CLASS(PL_curstash));
811 struct xpvhv_aux *aux = HvAUX(PL_curstash);
812
813 resume_compcv_and_save(aux->xhv_class_suspended_initfields_compcv);
814 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
815 }
816
817 void
Perl_class_prepare_method_parse(pTHX_ CV * cv)818 Perl_class_prepare_method_parse(pTHX_ CV *cv)
819 {
820 PERL_ARGS_ASSERT_CLASS_PREPARE_METHOD_PARSE;
821
822 assert(cv == PL_compcv);
823 assert(HvSTASH_IS_CLASS(PL_curstash));
824
825 /* We expect this to be at the start of sub parsing, so there won't be
826 * anything in the pad yet
827 */
828 assert(PL_comppad_name_fill == 0);
829
830 PADOFFSET padix;
831
832 padix = pad_add_name_pvs("$self", 0, NULL, NULL);
833 assert(padix == PADIX_SELF);
834 PERL_UNUSED_VAR(padix);
835
836 intro_my();
837
838 CvNOWARN_AMBIGUOUS_on(cv);
839 CvIsMETHOD_on(cv);
840 }
841
842 OP *
Perl_class_wrap_method_body(pTHX_ OP * o)843 Perl_class_wrap_method_body(pTHX_ OP *o)
844 {
845 PERL_ARGS_ASSERT_CLASS_WRAP_METHOD_BODY;
846
847 if(!o)
848 return o;
849
850 PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv));
851
852 AV *fieldmap = newAV();
853 UV max_fieldix = 0;
854 SAVEFREESV((SV *)fieldmap);
855
856 /* padix 0 == @_; padix 1 == $self. Start at 2 */
857 for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) {
858 PADNAME *pn = PadnamelistARRAY(pnl)[padix];
859 if(!pn || !PadnameIsFIELD(pn))
860 continue;
861
862 U32 fieldix = PadnameFIELDINFO(pn)->fieldix;
863 if(fieldix > max_fieldix)
864 max_fieldix = fieldix;
865
866 av_push(fieldmap, newSVuv(padix));
867 av_push(fieldmap, newSVuv(fieldix));
868 }
869
870 UNOP_AUX_item *aux = NULL;
871
872 if(av_count(fieldmap)) {
873 Newx(aux, 2 + av_count(fieldmap), UNOP_AUX_item);
874
875 UNOP_AUX_item *ap = aux;
876
877 (ap++)->uv = av_count(fieldmap) / 2;
878 (ap++)->uv = max_fieldix;
879
880 for(Size_t i = 0; i < av_count(fieldmap); i++)
881 (ap++)->uv = SvUV(AvARRAY(fieldmap)[i]);
882 }
883
884 /* If this is an empty method body then o will be an OP_STUB and not a
885 * list. This will confuse op_sibling_splice() */
886 if(o->op_type != OP_LINESEQ)
887 o = newLISTOP(OP_LINESEQ, 0, o, NULL);
888
889 op_sibling_splice(o, NULL, 0, newUNOP_AUX(OP_METHSTART, 0, NULL, aux));
890
891 return o;
892 }
893
894 void
Perl_class_add_field(pTHX_ HV * stash,PADNAME * pn)895 Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn)
896 {
897 PERL_ARGS_ASSERT_CLASS_ADD_FIELD;
898
899 assert(HvSTASH_IS_CLASS(stash));
900 struct xpvhv_aux *aux = HvAUX(stash);
901
902 PADOFFSET fieldix = aux->xhv_class_next_fieldix;
903 aux->xhv_class_next_fieldix++;
904
905 Newxz(PadnameFIELDINFO(pn), 1, struct padname_fieldinfo);
906 PadnameFLAGS(pn) |= PADNAMEf_FIELD;
907
908 PadnameFIELDINFO(pn)->refcount = 1;
909 PadnameFIELDINFO(pn)->fieldix = fieldix;
910 PadnameFIELDINFO(pn)->fieldstash = (HV *)SvREFCNT_inc(stash);
911
912 if(!aux->xhv_class_fields)
913 aux->xhv_class_fields = newPADNAMELIST(0);
914
915 padnamelist_store(aux->xhv_class_fields, PadnamelistMAX(aux->xhv_class_fields)+1, pn);
916 PadnameREFCNT_inc(pn);
917 }
918
919 static void
apply_field_attribute_param(pTHX_ PADNAME * pn,SV * value)920 apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value)
921 {
922 if(!value)
923 /* Default to name minus the sigil */
924 value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn));
925
926 if(PadnamePV(pn)[0] != '$')
927 croak("Only scalar fields can take a :param attribute");
928
929 if(PadnameFIELDINFO(pn)->paramname)
930 croak("Field already has a parameter name, cannot add another");
931
932 HV *stash = PadnameFIELDINFO(pn)->fieldstash;
933 assert(HvSTASH_IS_CLASS(stash));
934 struct xpvhv_aux *aux = HvAUX(stash);
935
936 if(aux->xhv_class_param_map &&
937 hv_exists_ent(aux->xhv_class_param_map, value, 0))
938 croak("Cannot assign :param(%" SVf ") to field %" SVf " because that name is already in use",
939 SVfARG(value), SVfARG(PadnameSV(pn)));
940
941 PadnameFIELDINFO(pn)->paramname = SvREFCNT_inc(value);
942
943 if(!aux->xhv_class_param_map)
944 aux->xhv_class_param_map = newHV();
945
946 (void)hv_store_ent(aux->xhv_class_param_map, value, newSVuv(PadnameFIELDINFO(pn)->fieldix), 0);
947 }
948
949 static struct {
950 const char *name;
951 bool requires_value;
952 void (*apply)(pTHX_ PADNAME *pn, SV *value);
953 } const field_attributes[] = {
954 { .name = "param",
955 .requires_value = false,
956 .apply = &apply_field_attribute_param,
957 },
958 {0}
959 };
960
961 static void
S_class_apply_field_attribute(pTHX_ PADNAME * pn,OP * attr)962 S_class_apply_field_attribute(pTHX_ PADNAME *pn, OP *attr)
963 {
964 assert(attr->op_type == OP_CONST);
965
966 SV *name, *value;
967 split_attr_nameval(cSVOPx_sv(attr), &name, &value);
968
969 for(int i = 0; field_attributes[i].name; i++) {
970 /* TODO: These attribute names are not UTF-8 aware */
971 if(!strEQ(SvPVX(name), field_attributes[i].name))
972 continue;
973
974 if(field_attributes[i].requires_value && !(value && SvOK(value)))
975 croak("Field attribute %" SVf " requires a value", SVfARG(name));
976
977 (*field_attributes[i].apply)(aTHX_ pn, value);
978 return;
979 }
980
981 croak("Unrecognized field attribute %" SVf, SVfARG(name));
982 }
983
984 void
Perl_class_apply_field_attributes(pTHX_ PADNAME * pn,OP * attrlist)985 Perl_class_apply_field_attributes(pTHX_ PADNAME *pn, OP *attrlist)
986 {
987 PERL_ARGS_ASSERT_CLASS_APPLY_FIELD_ATTRIBUTES;
988
989 if(!attrlist)
990 return;
991 if(attrlist->op_type == OP_NULL) {
992 op_free(attrlist);
993 return;
994 }
995
996 if(attrlist->op_type == OP_LIST) {
997 OP *o = cLISTOPx(attrlist)->op_first;
998 assert(o->op_type == OP_PUSHMARK);
999 o = OpSIBLING(o);
1000
1001 for(; o; o = OpSIBLING(o))
1002 S_class_apply_field_attribute(aTHX_ pn, o);
1003 }
1004 else
1005 S_class_apply_field_attribute(aTHX_ pn, attrlist);
1006
1007 op_free(attrlist);
1008 }
1009
1010 void
Perl_class_set_field_defop(pTHX_ PADNAME * pn,OPCODE defmode,OP * defop)1011 Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop)
1012 {
1013 PERL_ARGS_ASSERT_CLASS_SET_FIELD_DEFOP;
1014
1015 assert(defmode == 0 || defmode == OP_ORASSIGN || defmode == OP_DORASSIGN);
1016
1017 assert(HvSTASH_IS_CLASS(PL_curstash));
1018
1019 forbid_outofblock_ops(defop, "field initialiser expression");
1020
1021 if(PadnameFIELDINFO(pn)->defop)
1022 op_free(PadnameFIELDINFO(pn)->defop);
1023
1024 char sigil = PadnamePV(pn)[0];
1025 switch(sigil) {
1026 case '$':
1027 defop = op_contextualize(defop, G_SCALAR);
1028 break;
1029
1030 case '@':
1031 case '%':
1032 defop = op_contextualize(op_force_list(defop), G_LIST);
1033 break;
1034 }
1035
1036 PadnameFIELDINFO(pn)->defop = newLISTOP(OP_LINESEQ, 0,
1037 newSTATEOP(0, NULL, NULL), defop);
1038 switch(defmode) {
1039 case OP_DORASSIGN:
1040 PadnameFIELDINFO(pn)->def_if_undef = true;
1041 break;
1042 case OP_ORASSIGN:
1043 PadnameFIELDINFO(pn)->def_if_false = true;
1044 break;
1045 }
1046 }
1047
1048 void
Perl_class_add_ADJUST(pTHX_ HV * stash,CV * cv)1049 Perl_class_add_ADJUST(pTHX_ HV *stash, CV *cv)
1050 {
1051 PERL_ARGS_ASSERT_CLASS_ADD_ADJUST;
1052
1053 assert(HvSTASH_IS_CLASS(stash));
1054 struct xpvhv_aux *aux = HvAUX(stash);
1055
1056 if(!aux->xhv_class_adjust_blocks)
1057 aux->xhv_class_adjust_blocks = newAV();
1058
1059 av_push(aux->xhv_class_adjust_blocks, (SV *)cv);
1060 }
1061
1062 /*
1063 * ex: set ts=8 sts=4 sw=4 et:
1064 */
1065