diff --git a/MANIFEST b/MANIFEST index c01186624586b..3248b2a6a0d76 100644 --- a/MANIFEST +++ b/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 diff --git a/class.c b/class.c index 43a4f482881b5..0d9d381e3ecb7 100644 --- a/class.c +++ b/class.c @@ -949,6 +949,87 @@ 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; + } + + 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 +1039,10 @@ static struct { .requires_value = false, .apply = &apply_field_attribute_param, }, + { .name = "reader", + .requires_value = false, + .apply = &apply_field_attribute_reader, + }, { NULL, false, NULL } }; diff --git a/pod/perlclass.pod b/pod/perlclass.pod index 4c158d9c38e45..b78cb12419d50 100644 --- a/pod/perlclass.pod +++ b/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 diff --git a/t/class/accessor.t b/t/class/accessor.t new file mode 100644 index 0000000000000..d93ca3333e6a1 --- /dev/null +++ b/t/class/accessor.t @@ -0,0 +1,51 @@ +#!./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 ); + 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;