From 38d8562642c236514055ef2c23a686f48ceafb4e Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Sat, 20 Sep 2025 05:12:35 +0200 Subject: [PATCH 1/4] mark CORE::__CLASS__ as non-ampable Previously: CORE::__CLASS__ and compile-time aliasing (as in `BEGIN { *cls = \&CORE::__CLASS__; } ... cls`) worked as expected, but runtime calls like `&CORE::__CLASS__()` and `my $ref = \&CORE::__CLASS__; ... $ref->()` would produce bizarre results, behaving like CORE::__FILE__ instead. Now the latter throw a "&CORE::__CLASS__ cannot be called directly" error. This is perhaps not entirely satisfactory, but __CLASS__ is a bit special (it is not a true constant and only usable in methods) and erroring cleanly is better than silently returning wrong results. Fixes #23737. Assorted changes: - Document core_prototype()'s `opnum` parameter. - Add comment explaining what `*opnum = 0` means (and why it makes no sense for KEY___CLASS__). - Don't hardcode assumptions about keyword codes in coresub_op(). Handle __PACKAGE__/__FILE__/__LINE__ explicitly and assert() nothing else is passed in. This effectively reverts commit c2f605db621e. - Remove CORE::__CLASS__ from op/coreamp.t as it is no longer "ampable". - Extend op/coresubs.t to handle more of the idiosyncrasies of CORE::__CLASS__. --- gv.c | 1 + op.c | 43 +++++++++++++++++++++++++++++-------------- t/op/coreamp.t | 1 - t/op/coresubs.t | 28 ++++++++++++++++++++++------ 4 files changed, 52 insertions(+), 21 deletions(-) diff --git a/gv.c b/gv.c index 396b7c439151..9856e03a2b7a 100644 --- a/gv.c +++ b/gv.c @@ -638,6 +638,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_until: case KEY_use : case KEY_when : case KEY_while : case KEY_x : case KEY_xor : case KEY_y : return NULL; + case KEY___CLASS__: case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: case KEY_eof : case KEY_exec: case KEY_exists : case KEY_lstat: diff --git a/op.c b/op.c index 72d9c4555464..8a85229e5116 100644 --- a/op.c +++ b/op.c @@ -16067,7 +16067,9 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) This function assigns the prototype of the named core function to C, or to a new mortal SV if C is C. It returns the modified C, or C if the core function has no prototype. C is a code as returned -by C. It must not be equal to 0. +by C. It must not be equal to 0. C should be either C +or the address of a variable that will be set to the op number corresponding to +C, if any. =cut */ @@ -16106,13 +16108,14 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code, case KEY_values: retsetpvs("\\[%@]", OP_VALUES); case KEY_each: retsetpvs("\\[%@]", OP_EACH); case KEY_pos: retsetpvs(";\\[$*]", OP_POS); - case KEY___CLASS__: case KEY___FILE__: case KEY___LINE__: case KEY___PACKAGE__: + /* special case: + 0 means "no actual op, but can be emulated using caller()" + */ retsetpvs("", 0); - case KEY_evalbytes: - name = "entereval"; break; - case KEY_readpipe: - name = "backtick"; + case KEY_evalbytes: name = "entereval"; break; + case KEY_readpipe: name = "backtick"; break; + case KEY___CLASS__: name = "classname"; break; } #undef retsetpvs @@ -16179,14 +16182,26 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, PERL_ARGS_ASSERT_CORESUB_OP; switch(opnum) { - case 0: - return op_append_elem(OP_LINESEQ, - argop, - newSLICEOP(0, - newSVOP(OP_CONST, 0, newSViv(-code % 3)), - newOP(OP_CALLER,0) - ) - ); + case 0: { + IV caller_index = IV_MAX; + switch (-code) { + case KEY___PACKAGE__: caller_index = 0; break; + case KEY___FILE__: caller_index = 1; break; + case KEY___LINE__: caller_index = 2; break; + } + assert(caller_index < IV_MAX); + + return op_append_elem( + OP_LINESEQ, + argop, + newSLICEOP( + 0, + newSVOP(OP_CONST, 0, newSViv(caller_index)), + newOP(OP_CALLER, 0) + ) + ); + } + case OP_EACH: case OP_KEYS: case OP_VALUES: diff --git a/t/op/coreamp.t b/t/op/coreamp.t index b7082246ed40..82a6fd88b59b 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -303,7 +303,6 @@ undef *_; $tests++; pass('no crash with &CORE::foo when *_{ARRAY} is undef'); -test_proto '__CLASS__'; test_proto '__FILE__'; test_proto '__LINE__'; test_proto '__PACKAGE__'; diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 2991347d25d3..2d49711c8af7 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -73,12 +73,18 @@ while(<$kh>) { inlinable_ok($word, $args_for{$word} || join ",", map "\$$_", 1..$numargs); - next if $word eq "__CLASS__"; - # High-precedence tests my $hpcode; if (!$proto && defined $proto) { # nullary - $hpcode = "sub { () = my$word + 1 }"; + if ($word eq '__CLASS__') { + $hpcode = <<~_EOT_; + use feature 'class'; + no warnings 'experimental::class'; + class TmpClassA { method { () = ::my$word + 1 } } + _EOT_ + } else { + $hpcode = "sub { () = my$word + 1 }"; + } } elsif ($proto =~ /^;?$protochar\z/) { # unary $hpcode = "sub { () = my$word " @@ -91,7 +97,7 @@ while(<$kh>) { # ‘(eval 21)’ vs ‘(eval 22)’. no warnings 'numeric'; my $core = op_list(eval $hpcode =~ s/my/CORE::/r or die); - my $my = op_list(eval $hpcode or die); + my $my = op_list(eval $hpcode =~ s/TmpClassA/TmpClassB/r or die); is $my, $core, "precedence of CORE::$word without parens"; } @@ -104,7 +110,7 @@ while(<$kh>) { $tests ++; my $code = - "sub { () = (my$word(" + "() = (my$word(" . ( $args_for{$word} ? $args_for{$word}.',$7' @@ -114,7 +120,17 @@ while(<$kh>) { : 0 ) ) - . "))}"; + . "))"; + if ($word eq '__CLASS__') { + $code =~ s/\b(my$word)\b/::$1/g; + $code = <<~_EOT_; + use feature 'class'; + no warnings 'experimental::class'; + class TmpClassX { method { $code } } + _EOT_ + } else { + $code = "sub { $code }"; + } eval $code; my $desc = $desc{$word} || $word; like $@, qr/^Too many arguments for $desc/, From 0c324f05415e8af622726060fcc74756289ca05c Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Sat, 20 Sep 2025 05:28:52 +0200 Subject: [PATCH 2/4] document CORE::__CLASS__ as non-ampable Rearrange documentation slightly to make it clearer what you can(not) do with CORE::chomp, CORE::chop, etc. and add CORE::__CLASS__ to the list. --- lib/CORE.pod | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/CORE.pod b/lib/CORE.pod index 1f6c847e1386..d7c29a391e96 100644 --- a/lib/CORE.pod +++ b/lib/CORE.pod @@ -32,9 +32,7 @@ CORE package, but is part of Perl's syntax. For many Perl functions, the CORE package contains real subroutines. This feature is new in Perl 5.16. You can take references to these and make -aliases. However, some can only be called as barewords; i.e., you cannot -use ampersand syntax (C<&foo>) or call them through references. See the -C example above. These subroutines exist for all keywords except the following: +aliases. These subroutines exist for all keywords except the following: C<__DATA__>, C<__END__>, C, C, C, C, C, C, C, C, C, C, C, C, C, @@ -44,14 +42,16 @@ C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C -Calling with -ampersand syntax and through references does not work for the following -functions, as they have special syntax that cannot always be translated -into a simple list (e.g., C vs C): +However, some CORE subroutines can only be aliased and called as barewords; +i.e., you cannot use ampersand syntax (C<&foo>) or call them through +references. See the C example above. These are: -C, C, C, C, C, C, +C<__CLASS__>, C, C, C, C, C, C, C, C, C, C, C, C, C +This is because they have special syntax that cannot always be translated +into a simple list (e.g., C vs C) or other special behavior. + =head1 OVERRIDING CORE FUNCTIONS To override a Perl built-in routine with your own version, you need to From 0c0c1250591610a0d3e41f707d4eeefa52e39837 Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Sat, 20 Sep 2025 05:31:51 +0200 Subject: [PATCH 3/4] regen/keywords.pl: remove obsolete comment coresub_op() no longer hardcodes assumptions about the numeric values of __FILE__, __LINE__, __PACKAGE__ keyword symbols. --- keywords.c | 2 +- keywords.h | 2 +- regen/keywords.pl | 3 --- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/keywords.c b/keywords.c index 1b1fcc24943e..3a028a7f1804 100644 --- a/keywords.c +++ b/keywords.c @@ -3590,5 +3590,5 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) } /* Generated from: - * cc0991530edda2eb87e845d9347acc0f8d2debabab27608ef65ebd2b8d221c08 regen/keywords.pl + * f3a6d8313b10fef95e923ecd5b3f9ff0de0d5374103500ec010f8746e7ab556a regen/keywords.pl * ex: set ro ft=c: */ diff --git a/keywords.h b/keywords.h index b3f5ec4244ce..737b2f992a90 100644 --- a/keywords.h +++ b/keywords.h @@ -282,5 +282,5 @@ #define KEY_y 266 /* Generated from: - * cc0991530edda2eb87e845d9347acc0f8d2debabab27608ef65ebd2b8d221c08 regen/keywords.pl + * f3a6d8313b10fef95e923ecd5b3f9ff0de0d5374103500ec010f8746e7ab556a regen/keywords.pl * ex: set ro ft=c: */ diff --git a/regen/keywords.pl b/regen/keywords.pl index 26ccf515ef2e..0e30e225f0c0 100755 --- a/regen/keywords.pl +++ b/regen/keywords.pl @@ -115,9 +115,6 @@ END read_only_bottom_close_and_rename($_, [$0]) foreach $c, $h; -# coresub_op in op.c expects __FILE__, __LINE__ and __PACKAGE__ to be the -# first three. - __END__ NULL From 053aa589ab8d7e85eb176dc375f0bcd8c06a05fc Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Sat, 20 Sep 2025 05:42:55 +0200 Subject: [PATCH 4/4] perldelta for non-ampable CORE::__CLASS__ --- pod/perldelta.pod | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index f54d9e3ae285..e6ba3cbda474 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -428,6 +428,27 @@ manager will later use a regex to expand these into links. XXX +=item * C<&CORE::__CLASS__> no longer returns invalid results + +C would work as expected when used as a bareword or aliased: + + use feature qw(class); + class Foo { + BEGIN { *cls = \&CORE::__CLASS__; } + method bar() { + my $class1 = CORE::__CLASS__; # ok + my $class2 = cls; # ok + } + } + +But when called with an ampersand (C<&CORE::__CLASS__()>) or through a +reference (C<< my $ref = \&CORE::__CLASS__; $ref->() >>), it would return +unrelated strings. These runtime calls have been fixed to throw an error of the +form C<&CORE::__CLASS__ cannot be called directly> instead of silently +returning incorrect results. + +[GH #23737] + =item * C can now handle empty subroutine signatures Previously, calling the C API function with an empty