Recognise a :reader attribute on class fields

MANIFEST

@@ -5956,6 +5956,7 @@ t/bigmem/subst.t			Test s/// with large strings
 t/bigmem/subst2.t			Test s//EXPR/e with large strings
 t/bigmem/vec.t				Check vec() handles large offsets
 t/charset_tools.pl			To aid in portable testing across platforms with different character sets
+t/class/accessor.t			See if accessor methods work
 t/class/class.t				See if class declarations work
 t/class/construct.t			See if class constructors work
 t/class/destruct.t			See if class destruction works

class.c

@@ -489,6 +489,8 @@ static void S_split_attr_nameval(pTHX_ SV *sv, SV **namp, SV **valp)
 
         if(value_max >= value_at)
             *valp = sv_2mortal(newSVpvn_utf8(value_at, value_max - value_at + 1, do_utf8));
+        else
+            *valp = NULL;
     }
     else {
         *namp = sv;
@@ -949,6 +951,88 @@ apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value)
     (void)hv_store_ent(aux->xhv_class_param_map, value, newSVuv(PadnameFIELDINFO(pn)->fieldix), 0);
 }
 
+static void
+apply_field_attribute_reader(pTHX_ PADNAME *pn, SV *value)
+{
+    if(value)
+        SvREFCNT_inc(value);
+    else
+        /* Default to name minus the sigil */
+        value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn));
+
+    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;
+        Newx(aux, 2 + 2, UNOP_AUX_item);
+
+        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;
+    {
+        UNOP_AUX_item *aux;
+        Newx(aux, 3, UNOP_AUX_item);
+
+        aux[0].iv = 0; /* params */
+        aux[1].iv = 0; /* opt_params */
+        aux[2].iv = 0; /* slurpy */
+
+        argcheckop = newUNOP_AUX(OP_ARGCHECK, 0, NULL, aux);
+    }
+
+    OP *retop;
+    {
+        OPCODE optype = 0;
+        switch(PadnamePV(pn)[0]) {
+            case '$': optype = OP_PADSV; break;
+            case '@': optype = OP_PADAV; break;
+            case '%': optype = OP_PADHV; break;
+            default: NOT_REACHED;
+        }
+
+        retop = newLISTOP(OP_RETURN, 0,
+            newOP(OP_PUSHMARK, 0),
+            newPADxVOP(optype, 0, padix));
+    }
+
+    OP *ops = newLISTOPn(OP_LINESEQ, 0,
+            newSTATEOP(0, NULL, NULL),
+            methstartop,
+            argcheckop,
+            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;
@@ -958,6 +1042,10 @@ static struct {
       .requires_value = false,
       .apply          = &apply_field_attribute_param,
     },
+    { .name           = "reader",
+      .requires_value = false,
+      .apply          = &apply_field_attribute_reader,
+    },
     { NULL, false, NULL }
 };
 

pod/perlclass.pod

@@ -227,6 +227,36 @@ If there is no defaulting expression then the parameter is required by the
 constructor; the caller must pass it or an exception is thrown. With a
 defaulting expression this becomes optional.
 
+=head3 :reader
+
+A field with a C<:reader> attribute will generate a reader accessor method
+automatically.  The generated method will have an empty (i.e. zero-argument)
+signature, and its body will simply return the value of the field variable.
+
+    field $s :reader;
+
+    # Equivalent to
+    field $s;
+    method s () { return $s; }
+
+By default accessor method will have the same name as the field (minus the
+leading sigil), but a different name can be specified in the attribute's value.
+
+    field $x :reader(get_x);
+
+    # Generates a method
+    method get_x () { return $x; }
+
+Reader methods can be applied to non-scalar fields. When invoked in list
+context they yield the contents of the field; in scalar context they yield
+the count of elements, as if the field variable had been placed in scalar
+context.
+
+    field @users :reader;
+    ...
+
+    scalar $instance->users;
+
 =head2 Method attributes
 
 None yet.
@@ -301,20 +331,20 @@ that makes all field initializer expressions appear within the same CV on
 ADJUST blocks as well, merging them all into a single CV per class. This will
 make it faster to invoke if a class has more than one of them.
 
-=item * Accessor generator attributes
+=item * More accessor generator attributes
 
-Attributes to request that accessor methods be generated for fields. Likely
-C<:reader> and C<:writer>.
+Attributes to request that other kinds of accessor methods be generated for
+fields. Likely C<:writer>.
 
     class X {
-        field $name :reader;
+        field $name :writer;
     }
 
 Equivalent to
 
     class X {
         field $name;
-        method name { return $name; }
+        method set_name ($new) { $name = $new; return $self; }
     }
 
 =item * Metaprogramming

t/class/accessor.t

@@ -0,0 +1,54 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+    set_up_inc('../lib');
+    require Config;
+}
+
+use v5.36;
+use feature 'class';
+no warnings 'experimental::class';
+
+# reader accessors
+{
+    class Testcase1 {
+        field $s :reader = "the scalar";
+
+        field @a :reader = qw( the array );
+
+        # Present-but-empty parens counts as default
+        field %h :reader() = qw( the hash );
+    }
+
+    my $o = Testcase1->new;
+    is($o->s, "the scalar", '$o->s accessor');
+    ok(eq_array([$o->a], [qw( the array )]), '$o->a accessor');
+    ok(eq_hash({$o->h}, {qw( the hash )}), '$o->h accessor');
+
+    is(scalar $o->a, 2, '$o->a accessor in scalar context');
+    is(scalar $o->h, 1, '$o->h accessor in scalar context');
+
+    # Read accessor does not permit arguments
+    ok(!eval { $o->s("value") },
+        'Reader accessor fails with argument');
+    like($@, qr/^Too many arguments for subroutine \'Testcase1::s\' \(got 1; expected 0\) at /,
+        'Failure from argument to accessor');
+}
+
+# Alternative names
+{
+    class Testcase2 {
+        field $f :reader(get_f) = "value";
+    }
+
+    is(Testcase2->new->get_f, "value", 'accessor with altered name');
+
+    ok(!eval { Testcase2->new->f },
+       'Accessor with altered name does not also generate original name');
+    like($@, qr/^Can't locate object method "f" via package "Testcase2" at /,
+       'Failure from lack of original name accessor');
+}
+
+done_testing;