class.c: Define a :writer attribute, applicable to scalar fields only

Author: leonerd

class.c

@@ -1055,6 +1055,104 @@ 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);
+    }
+
+    if(!valid_identifier_sv(value))
+        croak("%" SVf_QUOTEDPREFIX " is not a valid name for a generated method", value);
+
+    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;
@@ -1068,6 +1166,10 @@ static struct {
       .requires_value = false,
       .apply          = &apply_field_attribute_reader,
     },
+    { .name           = "writer",
+      .requires_value = false,
+      .apply          = &apply_field_attribute_writer,
+    },
     { NULL, false, NULL }
 };
 

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<set_> 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.

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<perlsub>.
 
+=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

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');
 }
 

t/lib/croak/class

@@ -165,3 +165,23 @@ class XXX {
 }
 EXPECT
 "abc-def" is not a valid name for a generated method at - line 6.
+########
+# Invalid method name for :writer attribute
+use v5.36;
+use feature 'class';
+no warnings 'experimental::class';
+class XXX {
+  field $x :writer(set-abc-def);
+}
+EXPECT
+"set-abc-def" is not a valid name for a generated method at - line 6.
+########
+# Writer on non-scalar field
+use v5.36;
+use feature 'class';
+no warnings 'experimental::class';
+class XXX {
+  field @things :writer;
+}
+EXPECT
+Cannot apply a :writer attribute to a non-scalar field at - line 6.