class.c

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