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 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 * 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 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); 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 ;) */ 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 327 invoke_class_seal(pTHX_ void *_arg) 328 { 329 class_seal_stash((HV *)_arg); 330 } 331 332 void 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) 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) 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) 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 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 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 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 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 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 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 * 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 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 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 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 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 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 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 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 * 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 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