mark CORE::__CLASS__ as non-ampable

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:

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<shove> 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<and>, C<cmp>, C<default>, C<do>, C<dump>,
 C<else>, C<elsif>, C<eq>, C<eval>, C<for>, C<foreach>, C<format>, C<ge>,
@@ -44,14 +42,16 @@ C<print>, C<printf>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<redo>, C<require>,
 C<return>, C<s>, C<say>, C<sort>, C<state>, C<sub>, C<tr>, C<unless>,
 C<until>, C<use>, C<when>, C<while>, C<x>, C<xor>, C<y>
 
-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<eof> vs C<eof()>):
+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<shove> example above.  These are:
 
-C<chomp>, C<chop>, C<defined>, C<delete>, C<eof>, C<exec>,
+C<__CLASS__>, C<chomp>, C<chop>, C<defined>, C<delete>, C<eof>, C<exec>,
 C<exists>, C<lstat>, C<split>, C<stat>, C<system>, C<truncate>, C<unlink>
 
+This is because they have special syntax that cannot always be translated
+into a simple list (e.g., C<eof> vs C<eof()>) or other special behavior.
+
 =head1 OVERRIDING CORE FUNCTIONS
 
 To override a Perl built-in routine with your own version, you need to

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<sv>, or
 to a new mortal SV if C<sv> is C<NULL>.  It returns the modified C<sv>, or
 C<NULL> if the core function has no prototype.  C<code> is a code as returned
-by C<keyword()>.  It must not be equal to 0.
+by C<keyword()>.  It must not be equal to 0.  C<opnum> should be either C<NULL>
+or the address of a variable that will be set to the op number corresponding to
+C<name>, 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:

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<CORE::__CLASS__> 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<parse_subsignature()> can now handle empty subroutine signatures
 
 Previously, calling the C<parse_subsignature()> API function with an empty

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

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__';

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/,