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