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