diff options
-rw-r--r-- | class.c | 130 | ||||
-rw-r--r-- | embed.fnc | 1 | ||||
-rw-r--r-- | embed.h | 2 | ||||
-rw-r--r-- | hv.h | 1 | ||||
-rw-r--r-- | lib/B/Op_private.pm | 5 | ||||
-rw-r--r-- | opcode.h | 137 | ||||
-rw-r--r-- | pad.h | 3 | ||||
-rw-r--r-- | perly.act | 4 | ||||
-rw-r--r-- | perly.h | 2 | ||||
-rw-r--r-- | perly.tab | 2 | ||||
-rw-r--r-- | perly.y | 2 | ||||
-rw-r--r-- | pod/perldiag.pod | 21 | ||||
-rw-r--r-- | proto.h | 2 | ||||
-rw-r--r-- | regen/op_private | 4 | ||||
-rw-r--r-- | t/class/field.t | 73 | ||||
-rw-r--r-- | t/class/inherit.t | 12 | ||||
-rw-r--r-- | t/lib/croak/class | 22 | ||||
-rw-r--r-- | toke.c | 5 |
18 files changed, 342 insertions, 86 deletions
@@ -18,7 +18,8 @@ #include "XSUB.h" enum { - PADIX_SELF = 1, + PADIX_SELF = 1, + PADIX_PARAMS = 2, }; void @@ -57,7 +58,8 @@ PP(pp_initfield) PADOFFSET fieldix = aux[0].uv; - SV *val; + SV *val = NULL; + switch(PL_op->op_private & (OPpINITFIELD_AV|OPpINITFIELD_HV)) { case 0: if(PL_op->op_flags & OPf_STACKED) @@ -168,9 +170,13 @@ XS(injected_constructor) ENTER; SAVETMPS; - EXTEND(SP, 1); + EXTEND(SP, 2); PUSHMARK(SP); PUSHs(self); + if(params) + PUSHs((SV *)params); // yes a raw HV + else + PUSHs(&PL_sv_undef); PUTBACK; call_sv((SV *)aux->xhv_class_initfields_cv, G_VOID); @@ -190,7 +196,7 @@ XS(injected_constructor) SAVETMPS; SPAGAIN; - EXTEND(SP, 1); + EXTEND(SP, 2); PUSHMARK(SP); PUSHs(self); /* I don't believe this needs to be an sv_mortalcopy() */ @@ -291,6 +297,15 @@ PP(pp_methstart) } } + if(PL_op->op_private & OPpINITFIELDS) { + SV *params = *av_fetch(GvAV(PL_defgv), 0, 0); + if(params && SvTYPE(params) == SVt_PVHV) { + SAVESPTR(PAD_SVl(PADIX_PARAMS)); + PAD_SVl(PADIX_PARAMS) = SvREFCNT_inc(params); + save_freesv(params); + } + } + return NORMAL; } @@ -351,6 +366,7 @@ Perl_class_setup_stash(pTHX_ HV *stash) aux->xhv_class_adjust_blocks = NULL; aux->xhv_class_fields = NULL; aux->xhv_class_next_fieldix = 0; + aux->xhv_class_param_map = NULL; aux->xhv_aux_flags |= HvAUXf_IS_CLASS; @@ -367,6 +383,10 @@ Perl_class_setup_stash(pTHX_ HV *stash) */ PADOFFSET padix = pad_add_name_pvs("$(self)", 0, NULL, NULL); assert(padix == PADIX_SELF); + + padix = pad_add_name_pvs("%(params)", 0, NULL, NULL); + assert(padix == PADIX_PARAMS); + PERL_UNUSED_VAR(padix); Newx(aux->xhv_class_suspended_initfields_compcv, 1, struct suspended_compcv); @@ -534,6 +554,10 @@ apply_class_attribute_isa(pTHX_ HV *stash, SV *value) for(U32 i = 0; i <= AvFILL(superaux->xhv_class_adjust_blocks); i++) av_push(aux->xhv_class_adjust_blocks, AvARRAY(superaux->xhv_class_adjust_blocks)[i]); } + + if(superaux->xhv_class_param_map) { + aux->xhv_class_param_map = newHVhv(superaux->xhv_class_param_map); + } } static struct { @@ -588,6 +612,16 @@ Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist) S_class_apply_attribute(aTHX_ stash, attrlist); } +static OP * +S_newCROAKOP(pTHX_ SV *message) +{ + OP *o = newLISTOP(OP_LIST, 0, + newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, message)); + return op_convert_list(OP_DIE, 0, o); +} +#define newCROAKOP(message) S_newCROAKOP(aTHX_ message) + void Perl_class_seal_stash(pTHX_ HV *stash) { @@ -626,7 +660,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) OP *ops = NULL; ops = op_append_list(OP_LINESEQ, ops, - newUNOP_AUX(OP_METHSTART, 0, NULL, NULL)); + newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL)); if(aux->xhv_class_superclass) { HV *superstash = aux->xhv_class_superclass; @@ -637,6 +671,8 @@ Perl_class_seal_stash(pTHX_ HV *stash) OP *o = NULL; o = op_append_list(OP_LIST, o, newPADxVOP(OP_PADSV, 0, PADIX_SELF)); + o = op_append_list(OP_LIST, o, + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS)); /* TODO: This won't work at all well under `use threads` because * it embeds the CV * to the superclass initfields CV right into * the optree. Maybe we'll have to pop it in the pad or something @@ -679,9 +715,42 @@ Perl_class_seal_stash(pTHX_ HV *stash) ops = op_append_list(OP_LINESEQ, ops, fieldcop); } + SV *paramname = PadnameFIELDINFO(pn)->paramname; + U8 op_priv = 0; switch(sigil) { case '$': + if(paramname) { + if(!valop) + valop = newCROAKOP( + newSVpvf("Required parameter '%" SVf "' is missing for %" HvNAMEf_QUOTEDPREFIX " constructor", + SVfARG(paramname), HvNAMEfARG(stash)) + ); + + OP *helemop = + newBINOP(OP_HELEM, 0, + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), + newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); + + if(PadnameFIELDINFO(pn)->def_if_undef) { + /* delete $params{$paramname} // DEFOP */ + valop = newLOGOP(OP_DOR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else if(PadnameFIELDINFO(pn)->def_if_false) { + /* delete $params{$paramname} || DEFOP */ + valop = newLOGOP(OP_OR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else { + /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */ + /* more efficient with the new OP_HELEMEXISTSOR */ + valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8, + helemop, valop); + } + + valop = op_contextualize(valop, G_SCALAR); + } break; case '@': @@ -697,7 +766,7 @@ Perl_class_seal_stash(pTHX_ HV *stash) } UNOP_AUX_item *aux; - Newx(aux, 1, UNOP_AUX_item); + Newx(aux, 2, UNOP_AUX_item); aux[0].uv = fieldix; @@ -819,12 +888,11 @@ Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn) PADOFFSET fieldix = aux->xhv_class_next_fieldix; aux->xhv_class_next_fieldix++; - Newx(PadnameFIELDINFO(pn), 1, struct padname_fieldinfo); + Newxz(PadnameFIELDINFO(pn), 1, struct padname_fieldinfo); PadnameFLAGS(pn) |= PADNAMEf_FIELD; PadnameFIELDINFO(pn)->fieldix = fieldix; PadnameFIELDINFO(pn)->fieldstash = (HV *)SvREFCNT_inc(stash); - PadnameFIELDINFO(pn)->defop = NULL; if(!aux->xhv_class_fields) aux->xhv_class_fields = newPADNAMELIST(0); @@ -833,11 +901,45 @@ Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn) PadnameREFCNT_inc(pn); } +static void +apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) +{ + if(!value) + /* Default to name minus the sigil */ + value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); + + if(PadnamePV(pn)[0] != '$') + croak("Only scalar fields can take a :param attribute"); + + if(PadnameFIELDINFO(pn)->paramname) + croak("Field already has a parameter name, cannot add another"); + + HV *stash = PadnameFIELDINFO(pn)->fieldstash; + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + if(aux->xhv_class_param_map && + hv_exists_ent(aux->xhv_class_param_map, value, 0)) + croak("Cannot assign :param(%" SVf ") to field %" SVf " because that name is already in use", + SVfARG(value), SVfARG(PadnameSV(pn))); + + PadnameFIELDINFO(pn)->paramname = SvREFCNT_inc(value); + + if(!aux->xhv_class_param_map) + aux->xhv_class_param_map = newHV(); + + hv_store_ent(aux->xhv_class_param_map, value, newSVuv(PadnameFIELDINFO(pn)->fieldix), 0); +} + static struct { const char *name; bool requires_value; void (*apply)(pTHX_ PADNAME *pn, SV *value); } const field_attributes[] = { + { .name = "param", + .requires_value = false, + .apply = &apply_field_attribute_param, + }, {0} }; @@ -885,10 +987,12 @@ Perl_class_apply_field_attributes(pTHX_ PADNAME *pn, OP *attrlist) } void -Perl_class_set_field_defop(pTHX_ PADNAME *pn, OP *defop) +Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) { PERL_ARGS_ASSERT_CLASS_SET_FIELD_DEFOP; + assert(defmode == 0 || defmode == OP_ORASSIGN || defmode == OP_DORASSIGN); + assert(HvSTASH_IS_CLASS(PL_curstash)); forbid_outofblock_ops(defop, "field initialiser expression"); @@ -910,6 +1014,14 @@ Perl_class_set_field_defop(pTHX_ PADNAME *pn, OP *defop) PadnameFIELDINFO(pn)->defop = newLISTOP(OP_LINESEQ, 0, newSTATEOP(0, NULL, NULL), defop); + switch(defmode) { + case OP_DORASSIGN: + PadnameFIELDINFO(pn)->def_if_undef = true; + break; + case OP_ORASSIGN: + PadnameFIELDINFO(pn)->def_if_false = true; + break; + } } void @@ -3987,6 +3987,7 @@ Cp |void |class_setup_stash \ |NN HV *stash Cp |void |class_set_field_defop \ |NN PADNAME *pn \ + |OPCODE defmode \ |NN OP *defop Cp |OP * |class_wrap_method_body \ |NULLOK OP *o @@ -1981,7 +1981,7 @@ # define class_prepare_initfield_parse() Perl_class_prepare_initfield_parse(aTHX) # define class_prepare_method_parse(a) Perl_class_prepare_method_parse(aTHX_ a) # define class_seal_stash(a) Perl_class_seal_stash(aTHX_ a) -# define class_set_field_defop(a,b) Perl_class_set_field_defop(aTHX_ a,b) +# define class_set_field_defop(a,b,c) Perl_class_set_field_defop(aTHX_ a,b,c) # define class_setup_stash(a) Perl_class_setup_stash(aTHX_ a) # define class_wrap_method_body(a) Perl_class_wrap_method_body(aTHX_ a) # define croak_kw_unless_class(a) Perl_croak_kw_unless_class(aTHX_ a) @@ -142,6 +142,7 @@ struct xpvhv_aux { AV *xhv_class_adjust_blocks; /* CVs containing the ADJUST blocks */ PADNAMELIST *xhv_class_fields; /* PADNAMEs with PadnameIsFIELD() */ PADOFFSET xhv_class_next_fieldix; + HV *xhv_class_param_map; /* Maps param names to field index stored in UV */ struct suspended_compcv *xhv_class_suspended_initfields_compcv; diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index bb1a07296f..0bd8128e99 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -444,7 +444,7 @@ $bits{method_named}{0} = $bf[0]; $bits{method_redir}{0} = $bf[0]; $bits{method_redir_super}{0} = $bf[0]; $bits{method_super}{0} = $bf[0]; -$bits{methstart}{0} = $bf[0]; +@{$bits{methstart}}{7,0} = ('OPpINITFIELDS', $bf[0]); @{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @{$bits{modulo}}{1,0} = ($bf[1], $bf[1]); @{$bits{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); @@ -650,6 +650,7 @@ our %defines = ( OPpHINT_STRICT_REFS => 2, OPpHUSH_VMSISH => 32, OPpINDEX_BOOLNEG => 64, + OPpINITFIELDS => 128, OPpINITFIELD_AV => 2, OPpINITFIELD_HV => 4, OPpITER_DEF => 8, @@ -763,6 +764,7 @@ our %labels = ( OPpHINT_STRICT_REFS => 'STRICT', OPpHUSH_VMSISH => 'HUSH', OPpINDEX_BOOLNEG => 'NEG', + OPpINITFIELDS => 'INITFIELDS', OPpINITFIELD_AV => 'INITFIELD_AV', OPpINITFIELD_HV => 'INITFIELD_HV', OPpITER_DEF => 'DEF', @@ -847,6 +849,7 @@ our %ops_using = ( OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], OPpHUSH_VMSISH => [qw(dbstate nextstate)], OPpINDEX_BOOLNEG => [qw(index rindex)], + OPpINITFIELDS => [qw(methstart)], OPpINITFIELD_AV => [qw(initfield)], OPpITER_DEF => [qw(enteriter)], OPpITER_REVERSED => [qw(enteriter iter)], @@ -2387,6 +2387,7 @@ END_EXTERN_C #define OPpDEFER_FINALLY 0x80 #define OPpENTERSUB_NOPAREN 0x80 #define OPpHELEMEXISTSOR_DELETE 0x80 +#define OPpINITFIELDS 0x80 #define OPpLVALUE 0x80 #define OPpLVAL_INTRO 0x80 #define OPpOFFBYONE 0x80 @@ -2469,6 +2470,7 @@ EXTCONST char PL_op_private_labels[] = { 'I','N','A','R','G','S','\0', 'I','N','B','I','N','\0', 'I','N','C','R','\0', + 'I','N','I','T','F','I','E','L','D','S','\0', 'I','N','I','T','F','I','E','L','D','_','A','V','\0', 'I','N','I','T','F','I','E','L','D','_','H','V','\0', 'I','N','P','L','A','C','E','\0', @@ -2534,14 +2536,14 @@ EXTCONST char PL_op_private_labels[] = { EXTCONST I16 PL_op_private_bitfields[] = { 0, 8, -1, 0, 8, -1, - 0, 657, -1, + 0, 668, -1, 0, 8, -1, 0, 8, -1, + 0, 675, -1, 0, 664, -1, - 0, 653, -1, - 1, -1, 0, 614, 1, 39, 2, 312, -1, + 1, -1, 0, 625, 1, 39, 2, 312, -1, 4, -1, 1, 185, 2, 192, 3, 199, -1, - 4, -1, 0, 614, 1, 39, 2, 312, 3, 131, -1, + 4, -1, 0, 625, 1, 39, 2, 312, 3, 131, -1, }; @@ -2969,8 +2971,8 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { [OP_FLOOR] = 78, [OP_IS_TAINTED] = 0, [OP_HELEMEXISTSOR] = 253, - [OP_METHSTART] = 0, - [OP_INITFIELD] = 255, + [OP_METHSTART] = 255, + [OP_INITFIELD] = 257, }; @@ -2989,84 +2991,85 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, is_bool, is_weak, weaken, unweaken, is_tainted, methstart */ - 0x387c, 0x4979, /* pushmark */ + 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, negate, i_negate, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, method, method_named, method_super, method_redir, method_redir_super, entergiven, leavegiven, enterwhen, leavewhen, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, is_bool, is_weak, weaken, unweaken, is_tainted */ + 0x39dc, 0x4ad9, /* pushmark */ 0x00bd, /* wantarray, runcv */ - 0x0558, 0x1b70, 0x4a2c, 0x45c8, 0x3da5, /* const */ - 0x387c, 0x3ef9, /* gvsv */ + 0x0558, 0x1b70, 0x4b8c, 0x4728, 0x3f05, /* const */ + 0x39dc, 0x4059, /* gvsv */ 0x19d5, /* gv */ 0x0067, /* gelem, lt, i_lt, gt, i_gt, le, i_le, ge, i_ge, eq, i_eq, ne, i_ne, ncmp, i_ncmp, slt, sgt, sle, sge, seq, sne, scmp, smartmatch, lslice, xor, isa */ - 0x387c, 0x4978, 0x03d7, /* padsv */ - 0x387c, 0x4978, 0x0003, /* padsv_store, lvavref */ - 0x387c, 0x4978, 0x06d4, 0x396c, 0x4749, /* padav */ - 0x387c, 0x4978, 0x06d4, 0x0770, 0x396c, 0x4748, 0x33e1, /* padhv */ - 0x387c, 0x1d58, 0x03d6, 0x396c, 0x3cc8, 0x4a24, 0x0003, /* rv2gv */ - 0x387c, 0x3ef8, 0x03d6, 0x4a24, 0x0003, /* rv2sv */ - 0x396c, 0x0003, /* av2arylen, akeys, values, keys */ - 0x3c3c, 0x1198, 0x0ef4, 0x014c, 0x4d28, 0x4a24, 0x0003, /* rv2cv */ + 0x39dc, 0x4ad8, 0x03d7, /* padsv */ + 0x39dc, 0x4ad8, 0x0003, /* padsv_store, lvavref */ + 0x39dc, 0x4ad8, 0x06d4, 0x3acc, 0x48a9, /* padav */ + 0x39dc, 0x4ad8, 0x06d4, 0x0770, 0x3acc, 0x48a8, 0x3541, /* padhv */ + 0x39dc, 0x1d58, 0x03d6, 0x3acc, 0x3e28, 0x4b84, 0x0003, /* rv2gv */ + 0x39dc, 0x4058, 0x03d6, 0x4b84, 0x0003, /* rv2sv */ + 0x3acc, 0x0003, /* av2arylen, akeys, values, keys */ + 0x3d9c, 0x1198, 0x0ef4, 0x014c, 0x4e88, 0x4b84, 0x0003, /* rv2cv */ 0x06d4, 0x0770, 0x0003, /* ref, blessed */ 0x018f, /* bless, glob, sprintf, formline, unpack, pack, join, anonlist, anonhash, splice, warn, die, reset, exit, close, pipe_op, fileno, umask, binmode, tie, dbmopen, sselect, select, getc, read, enterwrite, sysopen, sysseek, sysread, syswrite, eof, tell, seek, truncate, fcntl, ioctl, send, recv, socket, sockpair, bind, connect, listen, accept, shutdown, gsockopt, ssockopt, open_dir, seekdir, gmtime, shmget, shmctl, shmread, shmwrite, msgget, msgctl, msgsnd, msgrcv, semop, semget, semctl, ghbyaddr, gnbyaddr, gpbynumber, gsbyname, gsbyport, syscall */ - 0x40dc, 0x3ff8, 0x2cf4, 0x2c30, 0x0003, /* backtick */ + 0x423c, 0x4158, 0x2cf4, 0x2c30, 0x0003, /* backtick */ 0x06d5, /* subst */ - 0x129c, 0x23d8, 0x0ad4, 0x488c, 0x2768, 0x5004, 0x08e1, /* trans, transr */ + 0x129c, 0x23d8, 0x0ad4, 0x49ec, 0x2768, 0x5164, 0x08e1, /* trans, transr */ 0x10dc, 0x05f8, 0x0067, /* sassign */ - 0x0d98, 0x0c94, 0x0b90, 0x396c, 0x06c8, 0x0067, /* aassign */ - 0x4dd0, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, refaddr, reftype, ceil, floor */ - 0x387c, 0x4978, 0x32f4, 0x4dd0, 0x0003, /* undef */ - 0x06d4, 0x396c, 0x0003, /* pos */ - 0x4dd0, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract */ + 0x0d98, 0x0c94, 0x0b90, 0x3acc, 0x06c8, 0x0067, /* aassign */ + 0x4f30, 0x0003, /* chomp, schomp, scomplement, sin, cos, exp, log, sqrt, int, hex, oct, abs, ord, chr, chroot, rmdir, refaddr, reftype, ceil, floor */ + 0x39dc, 0x4ad8, 0x3454, 0x4f30, 0x0003, /* undef */ + 0x06d4, 0x3acc, 0x0003, /* pos */ + 0x4f30, 0x0067, /* pow, multiply, i_multiply, divide, i_divide, modulo, i_modulo, add, i_add, subtract, i_subtract */ 0x1658, 0x0067, /* repeat */ - 0x3b58, 0x4dd0, 0x0067, /* concat */ - 0x387c, 0x0338, 0x1d54, 0x4dd0, 0x4b0c, 0x0003, /* multiconcat */ - 0x4dd0, 0x018f, /* stringify, atan2, rand, srand, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */ - 0x4dd0, 0x4f29, /* left_shift, right_shift, nbit_and, nbit_xor, nbit_or, ncomplement */ - 0x4f29, /* bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, complement */ - 0x06d4, 0x4dd0, 0x0003, /* length */ - 0x4330, 0x396c, 0x012b, /* substr */ - 0x396c, 0x0067, /* vec */ - 0x3ad8, 0x06d4, 0x4dd0, 0x018f, /* index, rindex */ - 0x387c, 0x3ef8, 0x06d4, 0x396c, 0x4748, 0x4a24, 0x0003, /* rv2av */ + 0x3cb8, 0x4f30, 0x0067, /* concat */ + 0x39dc, 0x0338, 0x1d54, 0x4f30, 0x4c6c, 0x0003, /* multiconcat */ + 0x4f30, 0x018f, /* stringify, atan2, rand, srand, crypt, push, unshift, flock, chdir, chown, unlink, chmod, utime, rename, link, symlink, mkdir, waitpid, system, exec, kill, getpgrp, setpgrp, getpriority, setpriority, sleep */ + 0x4f30, 0x5089, /* left_shift, right_shift, nbit_and, nbit_xor, nbit_or, ncomplement */ + 0x5089, /* bit_and, bit_xor, bit_or, sbit_and, sbit_xor, sbit_or, complement */ + 0x06d4, 0x4f30, 0x0003, /* length */ + 0x4490, 0x3acc, 0x012b, /* substr */ + 0x3acc, 0x0067, /* vec */ + 0x3c38, 0x06d4, 0x4f30, 0x018f, /* index, rindex */ + 0x39dc, 0x4058, 0x06d4, 0x3acc, 0x48a8, 0x4b84, 0x0003, /* rv2av */ 0x025f, /* aelemfast, aelemfast_lex, aelemfastlex_store */ - 0x387c, 0x3778, 0x03d6, 0x396c, 0x0067, /* aelem, helem */ - 0x387c, 0x396c, 0x4749, /* aslice, hslice */ - 0x396d, /* kvaslice, kvhslice */ - 0x387c, 0x4698, 0x3494, 0x0003, /* delete */ - 0x4c58, 0x0003, /* exists */ - 0x387c, 0x3ef8, 0x06d4, 0x0770, 0x396c, 0x4748, 0x4a24, 0x33e1, /* rv2hv */ - 0x387c, 0x3778, 0x1314, 0x1c70, 0x396c, 0x4a24, 0x0003, /* multideref */ - 0x387c, 0x3ef8, 0x0410, 0x358c, 0x2a69, /* split */ - 0x387c, 0x2499, /* list */ - 0x387c, 0x4978, 0x0214, 0x4dd0, 0x018f, /* emptyavhv */ - 0x15b0, 0x30cc, 0x4428, 0x31c4, 0x3e61, /* sort */ - 0x30cc, 0x0003, /* reverse */ + 0x39dc, 0x38d8, 0x03d6, 0x3acc, 0x0067, /* aelem, helem */ + 0x39dc, 0x3acc, 0x48a9, /* aslice, hslice */ + 0x3acd, /* kvaslice, kvhslice */ + 0x39dc, 0x47f8, 0x35f4, 0x0003, /* delete */ + 0x4db8, 0x0003, /* exists */ + 0x39dc, 0x4058, 0x06d4, 0x0770, 0x3acc, 0x48a8, 0x4b84, 0x3541, /* rv2hv */ + 0x39dc, 0x38d8, 0x1314, 0x1c70, 0x3acc, 0x4b84, 0x0003, /* multideref */ + 0x39dc, 0x4058, 0x0410, 0x36ec, 0x2a69, /* split */ + 0x39dc, 0x2499, /* list */ + 0x39dc, 0x4ad8, 0x0214, 0x4f30, 0x018f, /* emptyavhv */ + 0x15b0, 0x322c, 0x4588, 0x3324, 0x3fc1, /* sort */ + 0x322c, 0x0003, /* reverse */ 0x06d4, 0x0003, /* grepwhile */ - 0x3618, 0x0003, /* flip, flop */ - 0x387c, 0x0003, /* cond_expr */ - 0x387c, 0x1198, 0x03d6, 0x014c, 0x4d28, 0x4a24, 0x2b41, /* entersub */ - 0x4198, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */ + 0x3778, 0x0003, /* flip, flop */ + 0x39dc, 0x0003, /* cond_expr */ + 0x39dc, 0x1198, 0x03d6, 0x014c, 0x4e88, 0x4b84, 0x2b41, /* entersub */ + 0x42f8, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */ 0x02aa, 0x0003, /* argelem */ 0x295c, 0x2838, 0x0003, /* argdefelem */ 0x00bc, 0x018f, /* caller */ 0x2675, /* nextstate, dbstate */ - 0x371c, 0x4199, /* leave */ - 0x387c, 0x3ef8, 0x120c, 0x44a5, /* enteriter */ - 0x44a5, /* iter */ - 0x371c, 0x0067, /* leaveloop */ - 0x513c, 0x0003, /* last, next, redo, dump, goto */ - 0x40dc, 0x3ff8, 0x2cf4, 0x2c30, 0x018f, /* open */ + 0x387c, 0x42f9, /* leave */ + 0x39dc, 0x4058, 0x120c, 0x4605, /* enteriter */ + 0x4605, /* iter */ + 0x387c, 0x0067, /* leaveloop */ + 0x529c, 0x0003, /* last, next, redo, dump, goto */ + 0x423c, 0x4158, 0x2cf4, 0x2c30, 0x018f, /* open */ 0x2010, 0x226c, 0x2128, 0x1ee4, 0x0003, /* ftrread, ftrwrite, ftrexec, fteread, ftewrite, fteexec */ 0x2010, 0x226c, 0x2128, 0x0003, /* ftis, ftsize, ftmtime, ftatime, ftctime, ftrowned, fteowned, ftzero, ftsock, ftchr, ftblk, ftfile, ftdir, ftpipe, ftsuid, ftsgid, ftsvtx, ftlink, fttty, fttext, ftbinary */ - 0x4dd1, /* wait, getppid, time */ - 0x4234, 0x0fb0, 0x082c, 0x4ea8, 0x2584, 0x0003, /* entereval */ - 0x3a3c, 0x0018, 0x14c4, 0x13e1, /* coreargs */ - 0x396c, 0x00c7, /* avhvswitch */ - 0x387c, 0x01fb, /* padrange */ - 0x387c, 0x4978, 0x04f6, 0x324c, 0x1ac8, 0x0067, /* refassign */ - 0x387c, 0x4978, 0x04f6, 0x324c, 0x1ac8, 0x0003, /* lvref */ - 0x387d, /* lvrefslice */ + 0x4f31, /* wait, getppid, time */ + 0x4394, 0x0fb0, 0x082c, 0x5008, 0x2584, 0x0003, /* entereval */ + 0x3b9c, 0x0018, 0x14c4, 0x13e1, /* coreargs */ + 0x3acc, 0x00c7, /* avhvswitch */ + 0x39dc, 0x01fb, /* padrange */ + 0x39dc, 0x4ad8, 0x04f6, 0x33ac, 0x1ac8, 0x0067, /* refassign */ + 0x39dc, 0x4ad8, 0x04f6, 0x33ac, 0x1ac8, 0x0003, /* lvref */ + 0x39dd, /* lvrefslice */ 0x1dfc, 0x0003, /* pushdefer */ 0x131c, 0x0003, /* helemexistsor */ - 0x2f28, 0x2d84, 0x0003, /* initfield */ + 0x2d9c, 0x0003, /* methstart */ + 0x3088, 0x2ee4, 0x0003, /* initfield */ }; @@ -3494,7 +3497,7 @@ EXTCONST U8 PL_op_private_valid[] = { [OP_FLOOR] = (OPpARG1_MASK|OPpTARGET_MY), [OP_IS_TAINTED] = (OPpARG1_MASK), [OP_HELEMEXISTSOR] = (OPpARG1_MASK|OPpHELEMEXISTSOR_DELETE), - [OP_METHSTART] = (OPpARG1_MASK), + [OP_METHSTART] = (OPpARG1_MASK|OPpINITFIELDS), [OP_INITFIELD] = (OPpARG1_MASK|OPpINITFIELD_AV|OPpINITFIELD_HV), }; @@ -97,6 +97,9 @@ struct padname_fieldinfo { PADOFFSET fieldix; /* index of this field within ObjectFIELDS() array */ HV *fieldstash; /* original class package which added this field */ OP *defop; /* optree fragment for defaulting expression */ + SV *paramname; /* name of the :param to look for in constructor */ + int def_if_undef : 1; /* default op uses //= */ + int def_if_false : 1; /* default op uses ||= */ }; @@ -2212,7 +2212,7 @@ case 2: case 302: #line 1572 "perly.y" { - class_set_field_defop((PADNAME *)(ps[-4].val.pval), (ps[0].val.opval)); + class_set_field_defop((PADNAME *)(ps[-4].val.pval), (ps[-2].val.ival), (ps[0].val.opval)); LEAVE; (yyval.opval) = newOP(OP_NULL, 0); } @@ -2345,6 +2345,6 @@ case 2: /* Generated from: - * cbe0c252d4da60dbe7511912aa9eeb8960b3a701c7273702cd4d180748105b8d perly.y + * c4b4e87c0539faad20b927f8b65030a63a6145426deafcd3a383c2b67d8c2cae perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ @@ -236,6 +236,6 @@ int yyparse (void); /* Generated from: - * cbe0c252d4da60dbe7511912aa9eeb8960b3a701c7273702cd4d180748105b8d perly.y + * c4b4e87c0539faad20b927f8b65030a63a6145426deafcd3a383c2b67d8c2cae perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ @@ -1330,6 +1330,6 @@ static const toketypes yy_type_tab[] = }; /* Generated from: - * cbe0c252d4da60dbe7511912aa9eeb8960b3a701c7273702cd4d180748105b8d perly.y + * c4b4e87c0539faad20b927f8b65030a63a6145426deafcd3a383c2b67d8c2cae perly.y * acf1cbfd2545faeaaa58b1cf0cf9d7f98b5be0752eb7a54528ef904a9e2e1ca7 regen_perly.pl * ex: set ro: */ @@ -1570,7 +1570,7 @@ fielddecl } term { - class_set_field_defop((PADNAME *)$fieldvar, $term); + class_set_field_defop((PADNAME *)$fieldvar, $ASSIGNOP, $term); LEAVE; $$ = newOP(OP_NULL, 0); } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 85feb2a8a3..d99f79c6e8 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -673,6 +673,12 @@ checking. Alternatively, if you are certain that you're calling the function correctly, you may put an ampersand before the name to avoid the warning. See L<perlsub>. +=item Cannot assign :param(%s) to field %s because that name is already in use + +(F) An attempt was made to apply a parameter name to a field, when the name +is already being used by another field in the same class, or one of its +parent classes. This would cause a name clash so is not allowed. + =item Cannot chr %f (F) You passed an invalid number (like an infinity or not-a-number) to C<chr>. @@ -2479,6 +2485,11 @@ PDP-11 or something? (F) A tied array claimed to have a negative number of elements, which is not possible. +=item Field already has a parameter name, cannot add another + +(F) A field may have at most one application of the C<:param> attribute to +assign a parameter name to it; once applied a second one is not allowed. + =item Field attribute %s requires a value (F) You specified an attribute for a field that would require a value to @@ -4661,6 +4672,11 @@ a backslash before the apostrophe (C<"In $name\'s house">). Support for the old package separator will be removed in Perl 5.40. +=item Only scalar fields can take a :param attribute + +(F) You tried to apply the C<:param> attribute to an array or hash field. +Currently this is not permitted. + =item %s() on unopened %s (W unopened) An I/O operation was attempted on a filehandle that was @@ -5661,6 +5677,11 @@ terminates. You might use ^# instead. See L<perlform>. search list. So the additional elements in the replacement list are meaningless. +=item Required parameter '%s' is missing for %s constructor + +(F) You called the constructor for a class that has a required named +parameter, but did not pass that parameter at all. + =item '(*%s' requires a terminating ':' in regex; marked by <-- HERE in m/%s/ (F) You used a construct that needs a colon and pattern argument. @@ -6268,7 +6268,7 @@ Perl_class_seal_stash(pTHX_ HV *stash); assert(stash) PERL_CALLCONV void -Perl_class_set_field_defop(pTHX_ PADNAME *pn, OP *defop); +Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop); # define PERL_ARGS_ASSERT_CLASS_SET_FIELD_DEFOP \ assert(pn); assert(defop) diff --git a/regen/op_private b/regen/op_private index 54ef8ddac9..64effe496b 100644 --- a/regen/op_private +++ b/regen/op_private @@ -876,6 +876,10 @@ addbits('helemexistsor', 7 => qw(OPpHELEMEXISTSOR_DELETE DELETE), ); +addbits('methstart', + 7 => qw(OPpINITFIELDS INITFIELDS), +); + addbits('initfield', 1 => qw(OPpINITFIELD_AV INITFIELD_AV), 2 => qw(OPpINITFIELD_HV INITFIELD_HV), diff --git a/t/class/field.t b/t/class/field.t index ef1dc82209..ba4e64baca 100644 --- a/t/class/field.t +++ b/t/class/field.t @@ -209,4 +209,77 @@ no warnings 'experimental::class'; ok(eq_array([$obj->six], [2, 3]), 'Array fields initialised from earlier fields'); } +# fields can take :param attributes to consume constructor parameters +{ + my $next_gamma = 4; + + class Test10 { + field $alpha :param = undef; + field $beta :param = 123; + field $gamma :param(delta) = $next_gamma++; + + method values { return ($alpha, $beta, $gamma); } + } + + my $obj = Test10->new( + alpha => "A", + beta => "B", + delta => "G", + ); + ok(eq_array([$obj->values], [qw(A B G)]), + 'Field initialised by :params'); + is($next_gamma, 4, 'Defaulting expression not evaluated for passed value'); + + $obj = Test10->new(); + ok(eq_array([$obj->values], [undef, 123, 4]), + 'Field initialised by defaulting expressions'); + is($next_gamma, 5, 'Defaulting expression evaluated for missing value'); +} + +# fields can be made non-optional +{ + class Test11 { + field $x :param; + field $y :param; + } + + Test11->new(x => 1, y => 1); + + ok(!eval { Test11->new(x => 2) }, + 'Constructor fails without y'); + like($@, qr/^Required parameter 'y' is missing for "Test11" constructor at /, + 'Failure from missing y argument'); +} + +# field assignment expressions on :param can use //= and ||= +{ + class Test12 { + field $if_exists :param(e) = "DEF"; + field $if_defined :param(d) //= "DEF"; + field $if_true :param(t) ||= "DEF"; + + method values { return ($if_exists, $if_defined, $if_true); } + } + + ok(eq_array( + [Test12->new(e => "yes", d => "yes", t => "yes")->values], + ["yes", "yes", "yes"]), + 'Values for "yes"'); + + ok(eq_array( + [Test12->new(e => 0, d => 0, t => 0)->values], + [0, 0, "DEF"]), + 'Values for 0'); + + ok(eq_array( + [Test12->new(e => undef, d => undef, t => undef)->values], + [undef, "DEF", "DEF"]), + 'Values for undef'); + + ok(eq_array( + [Test12->new()->values], + ["DEF", "DEF", "DEF"]), + 'Values for missing'); +} + done_testing; diff --git a/t/class/inherit.t b/t/class/inherit.t index 6a688f6e7e..03b2199683 100644 --- a/t/class/inherit.t +++ b/t/class/inherit.t @@ -59,4 +59,16 @@ no warnings 'experimental::class'; 'Exception thrown from :isa version test'); } +{ + class Test3A { + field $x :param; + method x { return $x; } + } + + class Test3B :isa(Test3A) {} + + my $obj = Test3B->new(x => "X"); + is($obj->x, "X", 'Constructor params passed through to superclass'); +} + done_testing; diff --git a/t/lib/croak/class b/t/lib/croak/class index d1870930c8..48a744b511 100644 --- a/t/lib/croak/class +++ b/t/lib/croak/class @@ -106,3 +106,25 @@ class XXX { } EXPECT Can't "last" out of field initialiser expression at - line 5. +######## +use strict; +no warnings 'experimental::class'; +use feature 'class'; +class XXX { + field $x :param(p); + field $y :param(p); +} +EXPECT +Cannot assign :param(p) to field $y because that name is already in use at - line 6. +######## +use strict; +no warnings 'experimental::class'; +use feature 'class'; +class XXX { + field $x :param(p); +} +class YYY :isa(XXX) { + field $y :param(p); +} +EXPECT +Cannot assign :param(p) to field $y because that name is already in use at - line 8. @@ -6043,8 +6043,9 @@ yyl_colon(pTHX_ char *s) if (*s != ';' && *s != '}' && !(PL_expect == XOPERATOR - ? (*s == '=' || *s == ')') - : (*s == '{' || *s == '('))) + /* if an operator is expected, permit =, //= and ||= or ) to end */ + ? (*s == '=' || *s == ')' || *s == '/' || *s == '|') + : (*s == '{' || *s == '('))) { const char q = ((*s == '\'') ? '"' : '\''); /* If here for an expression, and parsed no attrs, back off. */ |