From b4ac6223c45e67fb59f78b74fef773acb06dc64d Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Tue, 19 Nov 2024 16:52:23 +0000 Subject: [PATCH] class.c: Define a :writer attribute, applicable to scalar fields only --- class.c | 99 ++++++++++++++++++++++++++++++++++++++++++++++ pod/perlclass.pod | 27 +++++++++++++ pod/perldiag.pod | 7 ++++ t/class/accessor.t | 35 +++++++++++++--- 4 files changed, 163 insertions(+), 5 deletions(-) diff --git a/class.c b/class.c index fd981ba719fa1..9475fc98923df 100644 --- a/class.c +++ b/class.c @@ -1052,6 +1052,101 @@ apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value) CvIsMETHOD_on(cv); } +/* If '@_' is called "snail", then elements of it can be called "slugs"; i.e. + * snails out of their container. */ +#define newSLUGOP(idx) S_newSLUGOP(aTHX_ idx) +static OP * +S_newSLUGOP(pTHX_ IV idx) +{ + assert(idx >= 0 && idx <= 255); + OP *op = newGVOP(OP_AELEMFAST, 0, PL_defgv); + op->op_private = idx; + return op; +} + +static void +apply_field_attribute_writer(pTHX_ PADNAME *pn, SV *value) +{ + char sigil = PadnamePV(pn)[0]; + if(sigil != '$') + croak("Cannot apply a :writer attribute to a non-scalar field"); + + if(value) + SvREFCNT_inc(value); + else { + /* Default to "set_" . name minus the sigil */ + value = newSVpvs("set_"); + sv_catpvn_flags(value, PadnamePV(pn) + 1, PadnameLEN(pn) - 1, + PadnameUTF8(pn) ? SV_CATUTF8 : 0); + } + + PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; + + I32 floor_ix = start_subparse(FALSE, 0); + SAVEFREESV(PL_compcv); + + I32 save_ix = block_start(TRUE); + + PADOFFSET padix; + + padix = pad_add_name_pvs("$self", 0, NULL, NULL); + assert(padix == PADIX_SELF); + + padix = pad_add_name_pvn(PadnamePV(pn), PadnameLEN(pn), 0, NULL, NULL); + intro_my(); + + OP *methstartop; + { + UNOP_AUX_item *aux; + aux = (UNOP_AUX_item *)PerlMemShared_malloc( + sizeof(UNOP_AUX_item) * (2 + 2)); + + UNOP_AUX_item *ap = aux; + (ap++)->uv = 1; /* fieldcount */ + (ap++)->uv = fieldix; /* max_fieldix */ + + (ap++)->uv = padix; + (ap++)->uv = fieldix; + + methstartop = newUNOP_AUX(OP_METHSTART, 0, NULL, aux); + } + + OP *argcheckop; + { + struct op_argcheck_aux *aux = (struct op_argcheck_aux *) + PerlMemShared_malloc(sizeof(*aux)); + + aux->params = 1; + aux->opt_params = 0; + aux->slurpy = 0; + + argcheckop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, (UNOP_AUX_item *)aux); + } + + OP *assignop = newBINOP(OP_SASSIGN, 0, + newSLUGOP(0), + newPADxVOP(OP_PADSV, OPf_MOD|OPf_REF, padix)); + + OP *retop = newLISTOP(OP_RETURN, 0, + newOP(OP_PUSHMARK, 0), + newPADxVOP(OP_PADSV, 0, PADIX_SELF)); + + OP *ops = newLISTOPn(OP_LINESEQ, 0, + methstartop, + argcheckop, + assignop, + retop, + NULL); + + SvREFCNT_inc(PL_compcv); + ops = block_end(save_ix, ops); + + OP *nameop = newSVOP(OP_CONST, 0, value); + + CV *cv = newATTRSUB(floor_ix, nameop, NULL, NULL, ops); + CvIsMETHOD_on(cv); +} + static struct { const char *name; bool requires_value; @@ -1065,6 +1160,10 @@ static struct { .requires_value = false, .apply = &apply_field_attribute_reader, }, + { .name = "writer", + .requires_value = false, + .apply = &apply_field_attribute_writer, + }, { NULL, false, NULL } }; diff --git a/pod/perlclass.pod b/pod/perlclass.pod index c2db238520180..ea6988961be58 100644 --- a/pod/perlclass.pod +++ b/pod/perlclass.pod @@ -260,6 +260,33 @@ context. scalar $instance->users; +=head3 :writer + +A field with a C<:writer> attribute will generate a writer accessor method +automatically. The generated method will have a signature that consumes +exactly one argument, and its body will assign that scalar argument to the +field, and return the invocant object itself. + + field $s :writer; + + # Equivalent to + field $s; + method set_s($new) { $s = $new; return $self; } + +By default the accessor method will have the name of the field minus the +leading sigil with the string C prefixed to it, but a different name +can be specified in the attribute's value. + + field $x :writer(write_x); + + # Generates a method + method write_x ($new) { ... } + +Curerently, writer accessors can only be applied to scalar fields. Attempts +to apply this attribute to a non-scalar field will result in a fatal exception +at compile-time. This may be relaxed in a future version to allow writers on +array or hash fields. For now, these will have to be created manually. + =head2 Method attributes None yet. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 8585d808a7d8c..36fb98e4feeed 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -699,6 +699,13 @@ 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. +=item Cannot apply a :writer attribute to a non-scalar field + +(F) An attempt was made to use the C<:writer> attribute on a field that is +not a scalar (i.e. an array or hash). At the present version, these are only +permitted on scalar fields. You will have to manually create a writer +accessor method yourself. + =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 diff --git a/t/class/accessor.t b/t/class/accessor.t index be8e6e26c1ac3..979d3e1c7a013 100644 --- a/t/class/accessor.t +++ b/t/class/accessor.t @@ -37,17 +37,42 @@ no warnings 'experimental::class'; 'Failure from argument to accessor'); } -# Alternative names +# writer accessors on scalars { class Testcase2 { - field $f :reader(get_f) = "value"; + field $s :reader :writer = "initial"; + } + + my $o = Testcase2->new; + is($o->s, "initial", '$o->s accessor before modification'); + is($o->set_s("new-value"), $o, '$o->set_s accessor returns instance'); + is($o->s, "new-value", '$o->s accessor after modification'); + + # Write accessor wants exactly one argument + ok(!eval { $o->set_s() }, + 'Reader accessor fails with no argument'); + like($@, qr/^Too few arguments for subroutine \'Testcase2::set_s\' \(got 0; expected 1\) at /, + 'Failure from argument to accessor'); + ok(!eval { $o->set_s(1, 2) }, + 'Reader accessor fails with 2 arguments'); + like($@, qr/^Too many arguments for subroutine \'Testcase2::set_s\' \(got 2; expected 1\) at /, + 'Failure from argument to accessor'); +} + +# Alternative names +{ + class Testcase3 { + field $f :reader(get_f) :writer(write_f) = "value"; } - is(Testcase2->new->get_f, "value", 'accessor with altered name'); + is(Testcase3->new->get_f, "value", + 'read accessor with altered name'); + ok(Testcase3->new->write_f("new"), + 'write accessor with altered name'); - ok(!eval { Testcase2->new->f }, + ok(!eval { Testcase3->new->f }, 'Accessor with altered name does not also generate original name'); - like($@, qr/^Can't locate object method "f" via package "Testcase2" at /, + like($@, qr/^Can't locate object method "f" via package "Testcase3" at /, 'Failure from lack of original name accessor'); }