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 c2f605d.
- 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__.

Author: mauke

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:

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:

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