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 20enum { 21 PADIX_SELF = 1, 22 PADIX_PARAMS = 2, 23}; 24 25void 26Perl_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) 35SV * 36Perl_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 48PP(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 127XS(injected_constructor); 128XS(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 ;) */ 240PP(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 312static void 313invoke_class_seal(pTHX_ void *_arg) 314{ 315 class_seal_stash((HV *)_arg); 316} 317 318void 319Perl_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) 401static 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) 439static 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) 456static 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 495static void 496apply_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 564static 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 576static void 577S_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 599void 600Perl_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 625static OP * 626S_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 635void 636Perl_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 805void 806Perl_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 817void 818Perl_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 842OP * 843Perl_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 894void 895Perl_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 919static void 920apply_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 949static 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 961static void 962S_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 984void 985Perl_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 1010void 1011Perl_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 1048void 1049Perl_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