From 197e7dcdadf8a7430196dfe35098514c95992bdf Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 19 Jun 2024 15:33:01 +1000 Subject: [PATCH] remove use of ' as a package separator In general for tests I translate them to using :: if the test wasn't specifically for ', and the test didn't duplicate a similar test that did test ::. This doesn't just change the parsing stage from accepting ' instead of :: in names, but also removes the translation from ' to :: done in several places, but that's really there to support the syntax. --- embed.fnc | 9 +--- embed.h | 3 +- gv.c | 28 ++-------- lib/overload.t | 2 +- pod/perldiag.pod | 18 +------ proto.h | 7 +-- t/comp/package.t | 18 +++---- t/comp/parser.t | 37 ++++--------- t/lib/croak/toke | 18 ++++++- t/lib/warnings/toke | 31 +++-------- t/op/method.t | 8 +-- t/op/ref.t | 27 +++------- t/op/sort.t | 2 +- t/op/stash.t | 6 +-- t/op/stash_parse_gv.t | 4 +- t/uni/package.t | 12 ++--- t/uni/parser.t | 8 ++- t/uni/stash.t | 6 +-- t/uni/variables.t | 9 +--- toke.c | 119 +++++++++++------------------------------- 20 files changed, 104 insertions(+), 268 deletions(-) diff --git a/embed.fnc b/embed.fnc index 9a7716d41eac6..adfadd7c273b2 100644 --- a/embed.fnc +++ b/embed.fnc @@ -3004,12 +3004,6 @@ EXpx |char * |scan_word |NN char *s \ |STRLEN destlen \ |int allow_package \ |NN STRLEN *slp -EXpx |char * |scan_word6 |NN char *s \ - |NN char *dest \ - |STRLEN destlen \ - |int allow_package \ - |NN STRLEN *slp \ - |bool warn_tick Cp |U32 |seed : Only used by perl.c/miniperl.c, but defined in caretx.c ep |void |set_caret_X @@ -5901,8 +5895,7 @@ S |void |parse_ident |NN char **s \ |NN char * const e \ |int allow_package \ |bool is_utf8 \ - |bool check_dollar \ - |bool tick_warn + |bool check_dollar S |int |pending_ident RS |char * |scan_const |NN char *start RS |char * |scan_formline |NN char *s diff --git a/embed.h b/embed.h index df70b1c2e0838..904cb66c5850b 100644 --- a/embed.h +++ b/embed.h @@ -1625,7 +1625,7 @@ # define lop(a,b,c) S_lop(aTHX_ a,b,c) # define missingterm(a,b) S_missingterm(aTHX_ a,b) # define no_op(a,b) S_no_op(aTHX_ a,b) -# define parse_ident(a,b,c,d,e,f,g) S_parse_ident(aTHX_ a,b,c,d,e,f,g) +# define parse_ident(a,b,c,d,e,f) S_parse_ident(aTHX_ a,b,c,d,e,f) # define pending_ident() S_pending_ident(aTHX) # define scan_const(a) S_scan_const(aTHX_ a) # define scan_formline(a) S_scan_formline(aTHX_ a) @@ -1760,7 +1760,6 @@ # define report_uninit(a) Perl_report_uninit(aTHX_ a) # define scan_str(a,b,c,d,e) Perl_scan_str(aTHX_ a,b,c,d,e) # define scan_word(a,b,c,d,e) Perl_scan_word(aTHX_ a,b,c,d,e) -# define scan_word6(a,b,c,d,e,f) Perl_scan_word6(aTHX_ a,b,c,d,e,f) # define skipspace_flags(a,b) Perl_skipspace_flags(aTHX_ a,b) # define sv_magicext_mglob(a) Perl_sv_magicext_mglob(aTHX_ a) # define sv_only_taint_gmagic Perl_sv_only_taint_gmagic diff --git a/gv.c b/gv.c index 86c485c579012..92db109270731 100644 --- a/gv.c +++ b/gv.c @@ -1167,7 +1167,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le * method name. * * leaves last_separator pointing to the beginning of the - * last package separator (either ' or ::) or 0 + * last package separator (::) or 0 * if none was found. * * leaves name pointing at the beginning of the @@ -1176,11 +1176,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le const char *name_cursor = name; const char * const name_em1 = name_end - 1; /* name_end minus 1 */ for (name_cursor = name; name_cursor < name_end ; name_cursor++) { - if (*name_cursor == '\'') { - last_separator = name_cursor; - name = name_cursor + 1; - } - else if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') { + if (name_cursor < name_em1 && *name_cursor == ':' && name_cursor[1] == ':') { last_separator = name_cursor++; name = name_cursor + 1; } @@ -1782,7 +1778,6 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, const char *name_cursor; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; - char smallbuf[64]; /* small buffer to avoid a malloc when possible */ PERL_ARGS_ASSERT_PARSE_GV_STASH_NAME; @@ -1796,8 +1791,7 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, for (name_cursor = *name; name_cursor < name_end; name_cursor++) { if (name_cursor < name_em1 && - ((*name_cursor == ':' && name_cursor[1] == ':') - || *name_cursor == '\'')) + (*name_cursor == ':' && name_cursor[1] == ':')) { if (!*stash) *stash = PL_defstash; @@ -1812,22 +1806,6 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, key = *name; *len += 2; } - else { /* using ' for package separator */ - /* use our pre-allocated buffer when possible to save a malloc */ - char *tmpbuf; - if ( *len+2 <= sizeof smallbuf) - tmpbuf = smallbuf; - else { - /* only malloc once if needed */ - if (tmpfullbuf == NULL) /* only malloc&free once, a little more than needed */ - Newx(tmpfullbuf, full_len+2, char); - tmpbuf = tmpfullbuf; - } - Copy(*name, tmpbuf, *len, char); - tmpbuf[(*len)++] = ':'; - tmpbuf[(*len)++] = ':'; - key = tmpbuf; - } gvp = (GV**)hv_fetch(*stash, key, is_utf8 ? -((I32)*len) : (I32)*len, add); *gv = gvp ? *gvp : NULL; if (!*gv || *gv == (const GV *)&PL_sv_undef) { diff --git a/lib/overload.t b/lib/overload.t index 6447acd0f008f..7f8cb48a7d78e 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -2399,7 +2399,7 @@ is eval {"$a"}, overload::StrVal($a), { package mane; use overload q\""\ => "bear::strength"; - use overload bool => "bear'bouillon"; + use overload bool => "bear::bouillon"; } @bear::ISA = 'food'; sub food::strength { 'twine' } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 126e6fb568f4f..65f8f6f5742c5 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -481,7 +481,7 @@ results. of Perl. Check the #! line, or manually feed your script into Perl yourself. -=item Bad name after %s +=item Bad name after %s:: (F) You started to name a symbol by using a package prefix, and then didn't finish the symbol. In particular, you can't interpolate outside @@ -4782,22 +4782,6 @@ Cing a file, or when seeking past the end of a scalar opened for I/O (in anticipation of future reads and to imitate the behavior with real files). -=item Old package separator "'" deprecated - -(D deprecated::apostrophe_as_package_separator, syntax) You used the old package -separator "'" in a variable, subroutine or package name. Support for the -old package separator will be removed in Perl 5.42. - -=item Old package separator used in string - -(D deprecated::apostrophe_as_package_separator, syntax) You used the old package -separator, "'", in a variable named inside a double-quoted string; e.g., -C<"In $name's house">. This is equivalent to C<"In $name::s house">. If -you meant the former, put a backslash before the apostrophe -(C<"In $name\'s house">). - -Support for the old package separator will be removed in Perl 5.42. - =item Only scalar fields can take a :param attribute (F) You tried to apply the C<:param> attribute to an array or hash field. diff --git a/proto.h b/proto.h index 8c6ea3c04062c..b088e59ff608b 100644 --- a/proto.h +++ b/proto.h @@ -4177,11 +4177,6 @@ Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STR #define PERL_ARGS_ASSERT_SCAN_WORD \ assert(s); assert(dest); assert(slp) -PERL_CALLCONV char * -Perl_scan_word6(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp, bool warn_tick); -#define PERL_ARGS_ASSERT_SCAN_WORD6 \ - assert(s); assert(dest); assert(slp) - PERL_CALLCONV U32 Perl_seed(pTHX); #define PERL_ARGS_ASSERT_SEED @@ -9261,7 +9256,7 @@ S_no_op(pTHX_ const char * const what, char *s); assert(what) STATIC void -S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8, bool check_dollar, bool tick_warn); +S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8, bool check_dollar); # define PERL_ARGS_ASSERT_PARSE_IDENT \ assert(s); assert(d); assert(e) diff --git a/t/comp/package.t b/t/comp/package.t index 7b19513bddf2b..d3e8850a45119 100644 --- a/t/comp/package.t +++ b/t/comp/package.t @@ -18,15 +18,12 @@ $bar = 4; { package ABC; - no warnings qw(syntax deprecated); $blurfl = 5; - $main'a = $'b; -} -{ - no warnings qw(syntax deprecated); - $ABC'dyick = 6; + $main::a = $::b; } +$ABC::dyick = 6; + $xyz = 2; $main = join(':', sort(keys %main::)); @@ -36,13 +33,10 @@ $ABC = join(':', sort(keys %ABC::)); if ('a' lt 'A') { print $xyz eq 'bar:main:new:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n"; } else { - print $xyz eq 'ABC:BEGIN:bar:main:new:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; -} -print $ABC eq 'BEGIN:blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; -{ - no warnings qw(syntax deprecated); - print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n"; + print $xyz eq 'ABC:bar:main:new:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n"; } +print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n"; +print $main::blurfl == 123 ? "ok 3\n" : "not ok 3\n"; package ABC; diff --git a/t/comp/parser.t b/t/comp/parser.t index dbd5ecc842bce..eaf50f36bb160 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -8,7 +8,7 @@ BEGIN { chdir 't' if -d 't'; } -print "1..191\n"; +print "1..189\n"; sub failed { my ($got, $expected, $name) = @_; @@ -222,8 +222,12 @@ EOF # tests for "Bad name" eval q{ foo::$bar }; like( $@, qr/Bad name after foo::/, 'Bad name after foo::' ); -eval q{ foo''bar }; -like( $@, qr/Bad name after foo'/, 'Bad name after foo\'' ); +{ + # since ' is no longer usable in symbols, the error is no longer "Bad name" + no warnings "syntax"; # suppress String found where operator expeected + eval q{ foo''bar }; + like( $@, qr/syntax error at \(eval \d+\) line 1, near "foo''/, 'Syntax error for foo\'' ); +} # test for ?: context error eval q{($a ? $x : ($y)) = 5}; @@ -368,12 +372,11 @@ like($@, qr/BEGIN failed--compilation aborted/, 'BEGIN 7' ); } { - no warnings; # [perl #113016] CORE::print::foo - sub CORE'print'foo { 43 } # apostrophes intentional; do not tempt fate - sub CORE'foo'bar { 43 } + sub CORE::print::foo { 43 } + sub CORE::foo::bar { 43 } is CORE::print::foo, 43, 'CORE::print::foo is not CORE::print ::foo'; - is scalar eval "CORE::foo'bar", 43, "CORE::foo'bar is not an error"; + is scalar eval "CORE::foo::bar", 43, "CORE::foo'bar is not an error"; } # bug #71748 @@ -451,11 +454,6 @@ END eval 's/${< ( EXPECT Bareword found where operator expected (Do you need to predeclare "isa"?) at - line 9, near "isa => 'Int" (Might be a runaway multi-line '' string starting on line 4) -Bad name after Int' at - line 9. +syntax error at - line 9, near "isa => 'Int" +Execution of - aborted due to compilation errors. ######## # NAME Bad name after :: (with other helpful messages) sub has{} @@ -611,3 +612,18 @@ syntax error at - line 2, near "[ ==" (Might be a runaway multi-line // string starting on line 1) Execution of - aborted due to compilation errors. +######## +# NAME tick in names: initial character of sub name +sub 'Hello'_he_said (_); +EXPECT +Illegal declaration of anonymous subroutine at - line 1. +######## +# NAME tick in names: initial character of format name + format 'one = +ok @<< - format 'foo still works +$test +. +EXPECT +syntax error at - line 2, near "ok @<< - format '" + (Might be a runaway multi-line '' string starting on line 1) +Execution of - aborted due to compilation errors. diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index fc1c66378288b..476108858e21b 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -408,6 +408,10 @@ sort ("") EXPECT ######## +# NAME ' no longer is part of the symbol character set +# previously these would parse like: +# "${foo'bar}", but now they parse like "${foo}'bar" +# and any ' parsing for symbols is now gone, so no warning @foo::bar = 1..3; () = "$foo'bar"; () = "@foo'bar"; @@ -421,19 +425,8 @@ no warnings 'syntax', 'deprecated' ; () = "@foo'bar"; () = "$#foo'bar"; EXPECT -Old package separator used in string at - line 2. - (Did you mean "$foo\'bar" instead?) -Old package separator used in string at - line 3. - (Did you mean "@foo\'bar" instead?) -Old package separator used in string at - line 4. - (Did you mean "$#foo\'bar" instead?) -Old package separator used in string at - line 6. - (Did you mean "$foo\'bar" instead?) -Old package separator used in string at - line 7. - (Did you mean "@foo\'bar" instead?) -Old package separator used in string at - line 8. - (Did you mean "$#foo\'bar" instead?) ######## +# similar to the test above in that the parsing has changed use warnings 'syntax'; use utf8; @fooл::barл = 1..3; () = "$fooл'barл"; @@ -444,12 +437,7 @@ no warnings 'syntax', 'deprecated' ; () = "@fooл'barл"; () = "$#fooл'barл"; EXPECT -Old package separator used in string at - line 3. - (Did you mean "$fooл\'barл" instead?) -Old package separator used in string at - line 4. - (Did you mean "@fooл\'barл" instead?) -Old package separator used in string at - line 5. - (Did you mean "$#fooл\'barл" instead?) +Possible unintended interpolation of @fooл in string at - line 5. ######## # NAME deprecation of ' in names sub foo'bar { 1 } @@ -458,11 +446,8 @@ $a'b = 1; %a'd = (); package a'e; EXPECT -Old package separator "'" deprecated at - line 1. -Old package separator "'" deprecated at - line 2. -Old package separator "'" deprecated at - line 3. -Old package separator "'" deprecated at - line 4. -Old package separator "'" deprecated at - line 5. +OPTION fatal +Illegal declaration of subroutine main::foo at - line 1. ######## # toke.c use warnings 'ambiguous' ; diff --git a/t/op/method.t b/t/op/method.t index eaa129aee1c7d..ddadb87420e69 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -13,7 +13,7 @@ BEGIN { use strict; no warnings 'once'; -plan(tests => 163); +plan(tests => 161); { # RT #126042 &{1==1} * &{1==1} would crash @@ -253,12 +253,6 @@ sub OtherSouper::method { "Isidore Ropen, Draft Manager" } my @ret = $o->SUPER::method('whatever'); ::is $ret[0], $o, 'object passed to SUPER::method'; ::is $ret[1], 'whatever', 'argument passed to SUPER::method'; - { - no warnings qw(syntax deprecated); - @ret = $o->SUPER'method('whatever'); - } - ::is $ret[0], $o, "object passed to SUPER'method"; - ::is $ret[1], 'whatever', "argument passed to SUPER'method"; @ret = Saab->SUPER::method; ::is $ret[0], 'Saab', "package name passed to SUPER::method"; @ret = OtherSaab->SUPER::method; diff --git a/t/op/ref.t b/t/op/ref.t index 3cf6ab0472592..76b55b24ad9d4 100644 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -272,10 +272,8 @@ is (join('', sort values %$anonhash2), 'BARXYZ'); # Test bless operator. package MYHASH; -{ - no warnings qw(syntax deprecated); - $object = bless $main'anonhash2; -} +$object = bless $main::anonhash2; + main::is (ref $object, 'MYHASH'); main::is ($object->{ABC}, 'XYZ'); @@ -299,10 +297,7 @@ sub mymethod { $string = "bad"; $object = "foo"; $string = "good"; -{ - no warnings qw(syntax deprecated); - $main'anonhash2 = "foo"; -} +$main::anonhash2 = "foo"; $string = ""; DESTROY { @@ -319,10 +314,7 @@ package OBJ; @ISA = ('BASEOBJ'); -{ - no warnings qw(syntax deprecated); - $main'object = bless {FOO => 'foo', BAR => 'bar'}; -} +$main::object = bless {FOO => 'foo', BAR => 'bar'}; package main; @@ -335,13 +327,10 @@ is ($object->doit("BAR"), 'bar'); $foo = doit $object "FOO"; main::is ($foo, 'foo'); -{ - no warnings qw(syntax deprecated); - sub BASEOBJ'doit { - local $ref = shift; - die "Not an OBJ" unless ref $ref eq 'OBJ'; - $ref->{shift()}; - } +sub BASEOBJ::doit { + local $ref = shift; + die "Not an OBJ" unless ref $ref eq 'OBJ'; + $ref->{shift()}; } package UNIVERSAL; diff --git a/t/op/sort.t b/t/op/sort.t index bdb965dcee632..19c99961ac055 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -240,7 +240,7 @@ eval <<'CODE'; no warnings qw(deprecated syntax); my @result = sort main'Backwards 'one', 'two'; CODE -cmp_ok($@,'eq','',q(old skool package)); +cmp_ok($@,'ne','',q(old skool package)); eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub diff --git a/t/op/stash.t b/t/op/stash.t index a507c4239db13..f10834adcc875 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc( qw(../lib) ); } -plan( tests => 55 ); +plan( tests => 54 ); # Used to segfault (bug #15479) fresh_perl_like( @@ -301,10 +301,6 @@ fresh_perl_is( 'packages ending with :: are self-consistent'; } -# [perl #88138] ' not equivalent to :: before a null -${"a'\0b"} = "c"; -is ${"a::\0b"}, "c", "' is equivalent to :: before a null"; - # [perl #101486] Clobbering the current package ok eval ' package Do; diff --git a/t/op/stash_parse_gv.t b/t/op/stash_parse_gv.t index 9e143d979e15e..465480e331eb7 100644 --- a/t/op/stash_parse_gv.t +++ b/t/op/stash_parse_gv.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc(qw(../lib)); } -plan( tests => 5 ); +plan( tests => 3 ); my $long = 'x' x 100; my $short = 'abcd'; @@ -14,9 +14,7 @@ my $short = 'abcd'; my @tests = ( [ $long, 'long package name: one word' ], [ join( '::', $long, $long ), 'long package name: multiple words' ], - [ join( q['], $long, $long ), q[long package name: multiple words using "'" separator] ], [ join( '::', $long, $short, $long ), 'long & short package name: multiple words' ], - [ join( q['], $long, $short, $long ), q[long & short package name: multiple words using "'" separator] ], ); foreach my $t (@tests) { diff --git a/t/uni/package.t b/t/uni/package.t index 84d3ea32789f8..0b153f73ec5b8 100644 --- a/t/uni/package.t +++ b/t/uni/package.t @@ -34,23 +34,17 @@ ok 1, "sanity check. If we got this far, UTF-8 in package names is legal."; $ㄅĽuṞfⳐ = 5; } - { - no warnings qw(syntax deprecated); - $압Ƈ'd읯ⱪ = 6; #' - } + $압Ƈ::d읯ⱪ = 6; $ꑭʑ = 2; $ꑭʑ = join(':', sort(keys %ꑭʑ::)); $압Ƈ = join(':', sort(keys %압Ƈ::)); - ::is $ꑭʑ, 'BEGIN:bar:ニュー:ꑭʑ:압Ƈ', "comp/stash.t test 1"; + ::is $ꑭʑ, 'bar:ニュー:ꑭʑ:압Ƈ', "comp/stash.t test 1"; ::is $압Ƈ, "d읯ⱪ:ㄅĽuṞfⳐ", "comp/stash.t test 2"; - { - no warnings qw(syntax deprecated); - ::is $main'ㄅĽuṞfⳐ, 123, "comp/stash.t test 3"; - } + ::is $main::ㄅĽuṞfⳐ, 123, "comp/stash.t test 3"; package 압Ƈ; diff --git a/t/uni/parser.t b/t/uni/parser.t index d3aa745272245..6fdd997491633 100644 --- a/t/uni/parser.t +++ b/t/uni/parser.t @@ -187,8 +187,12 @@ is ${"main::\345\225\217"}, undef, "..and using the encoded form doesn't"; # tests for "Bad name" eval q{ Ｆｏｏ::$bar }; like( $@, qr/Bad name after Ｆｏｏ::/, 'Bad name after Ｆｏｏ::' ); -eval q{ Ｆｏｏ''bar }; -like( $@, qr/Bad name after Ｆｏｏ'/, 'Bad name after Ｆｏｏ\'' ); +{ + # since ' is no longer usable in symbols, the error is no longer "Bad name" + no warnings "syntax"; # suppress String found where operator expeected + eval q{ Ｆｏｏ''bar }; + like( $@, qr/syntax error at \(eval \d+\) line 1, near \"Ｆｏｏ\'\'/, 'Syntax error for Ｆｏｏ\'' ); +} { no warnings 'utf8'; diff --git a/t/uni/stash.t b/t/uni/stash.t index a069aa111e235..7bfdc6cac3c5d 100644 --- a/t/uni/stash.t +++ b/t/uni/stash.t @@ -13,7 +13,7 @@ BEGIN { use utf8; use open qw( :utf8 :std ); -plan( tests => 49 ); +plan( tests => 48 ); #These come from op/my_stash.t { @@ -283,8 +283,4 @@ plan( tests => 49 ); ok eval { Bèàr::::bàz() }, 'packages ending with :: are self-consistent'; } - - # [perl #88138] ' not equivalent to :: before a null - ${"à'\0b"} = "c"; - is ${"à::\0b"}, "c", "' is equivalent to :: before a null"; } diff --git a/t/uni/variables.t b/t/uni/variables.t index 2c18951a1a263..c5284de3e9f53 100644 --- a/t/uni/variables.t +++ b/t/uni/variables.t @@ -14,7 +14,7 @@ use utf8; use open qw( :utf8 :std ); no warnings qw(misc reserved); -plan (tests => 66880); +plan (tests => 66879); # ${single:colon} should not be treated as a simple variable, but as a # block with a label inside. @@ -35,16 +35,11 @@ plan (tests => 66880); ); } -# ${yadda'etc} and ${yadda::etc} should both work under strict +# and ${yadda::etc} should both work under strict { local $@; eval q; is($@, '', q<${package::var} works>); - - no warnings qw(syntax deprecated); - local $@; - eval q; - is($@, '', q<...as does ${package'var}>); } # The first character in ${...} should respect the rules diff --git a/toke.c b/toke.c index 0eb3470fa7715..b499b83c29e51 100644 --- a/toke.c +++ b/toke.c @@ -2263,7 +2263,7 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || (allow_pack && *s == ':' && s[1] == ':') ) { - s = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len, allow_pack); + s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); if (check_keyword) { char *s2 = PL_tokenbuf; STRLEN len2 = len; @@ -4802,7 +4802,7 @@ S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) return *s == '(' ? METHCALL : METHCALL0; } - s = scan_word6(s, tmpbuf, sizeof tmpbuf, TRUE, &len, FALSE); + s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, * and s is the end of it * tmpbuf is a copy of it (but with single quotes as double colons) @@ -5251,7 +5251,7 @@ yyl_sigvar(pTHX_ char *s) /* read var name, including sigil, into PL_tokenbuf */ PL_tokenbuf[0] = sigil; parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1, - 0, cBOOL(UTF), FALSE, FALSE); + 0, cBOOL(UTF), FALSE); *dest = '\0'; assert(PL_tokenbuf[1]); /* we have a variable name */ } @@ -5488,7 +5488,7 @@ yyl_dollar(pTHX_ char *s) char tmpbuf[sizeof PL_tokenbuf]; int t2; STRLEN len; - scan_word6(s, tmpbuf, sizeof tmpbuf, TRUE, &len, FALSE); + scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); if ((t2 = keyword(tmpbuf, len, 0))) { /* binary operators exclude handle interpretations */ switch (t2) { @@ -5554,13 +5554,11 @@ yyl_sub(pTHX_ char *s, const int key) PL_parser->sig_seen = FALSE; if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) - || *s == '\'' || (*s == ':' && s[1] == ':')) { PL_expect = XATTRBLOCK; - d = scan_word6(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE, - &len, TRUE); + d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE, &len); if (key == KEY_format) format_name = S_newSV_maybe_utf8(aTHX_ s, d - s); *PL_tokenbuf = '&'; @@ -6154,7 +6152,7 @@ yyl_colon(pTHX_ char *s) I32 tmp; SV *sv; STRLEN len; - char *d = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len, FALSE); + char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) { if (tmp < 0) tmp = -tmp; switch (tmp) { @@ -6333,8 +6331,8 @@ yyl_leftcurly(pTHX_ char *s, const U8 formbrack) } if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) { STRLEN len; - d = scan_word6(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, - FALSE, &len, FALSE); + d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, + FALSE, &len); while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { @@ -7181,7 +7179,7 @@ yyl_foreach(pTHX_ char *s) /* skip optional package name, as in "for my abc $x (..)" */ if (UNLIKELY(isIDFIRST_lazy_if_safe(p, PL_bufend, UTF))) { STRLEN len; - p = scan_word6(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len, TRUE); + p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); p = skipspace(p); paren_is_valid = FALSE; } @@ -7210,8 +7208,8 @@ yyl_do(pTHX_ char *s, I32 orig_keyword) char *d; STRLEN len; *PL_tokenbuf = '&'; - d = scan_word6(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, - 1, &len, TRUE); + d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, + 1, &len); if (len && memNEs(PL_tokenbuf+1, len, "CORE") && !keyword(PL_tokenbuf + 1, len, 0)) { SSize_t off = s-SvPVX(PL_linestr); @@ -7246,7 +7244,7 @@ yyl_my(pTHX_ char *s, I32 my) s = skipspace(s); if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) { STRLEN len; - s = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len, TRUE); + s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (memEQs(PL_tokenbuf, len, "sub")) return yyl_sub(aTHX_ s, my); PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); @@ -7716,18 +7714,17 @@ yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c) /* Get the rest if it looks like a package qualifier */ - if (*s == '\'' || (*s == ':' && s[1] == ':')) { + if (*s == ':' && s[1] == ':') { STRLEN morelen; - s = scan_word6(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, - TRUE, &morelen, TRUE); + s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, + TRUE, &morelen); if (no_op_error) { no_op("Bareword",s); no_op_error = FALSE; } if (!morelen) - Perl_croak(aTHX_ "Bad name after %" UTF8f "%s", - UTF8fARG(UTF, len, PL_tokenbuf), - *s == '\'' ? "'" : "::"); + Perl_croak(aTHX_ "Bad name after %" UTF8f "::", + UTF8fARG(UTF, len, PL_tokenbuf)); len += morelen; pkgname = 1; } @@ -8468,7 +8465,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct s = skipspace(s); if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) { const char *t; - char *d = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len, FALSE); + char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); for (t=d; isSPACE(*t);) t++; if ( *t && memCHRs("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) @@ -8909,18 +8906,17 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct static int yyl_key_core(pTHX_ char *s, STRLEN len, struct code c) { - I32 key = 0; I32 orig_keyword = 0; STRLEN olen = len; char *d = s; s += 2; - s = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len, FALSE); - if ((*s == ':' && s[1] == ':') - || (!(key = keyword(PL_tokenbuf, len, 1)) && *s == '\'')) + s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); + if (*s == ':' && s[1] == ':') { Copy(PL_bufptr, PL_tokenbuf, olen, char); return yyl_just_a_word(aTHX_ d, olen, 0, c); } + I32 key = keyword(PL_tokenbuf, len, 1); if (!key) Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword", UTF8fARG(UTF, len, PL_tokenbuf)); @@ -8993,7 +8989,7 @@ yyl_keylookup(pTHX_ char *s, GV *gv) c.gv = gv; PL_bufptr = s; - s = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len, FALSE); + s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); /* Some keywords can be followed by any delimiter, including ':' */ anydelim = word_takes_any_delimiter(PL_tokenbuf, len); @@ -10317,10 +10313,8 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen, PERL_STATIC_INLINE void S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, - bool is_utf8, bool check_dollar, bool tick_warn) + bool is_utf8, bool check_dollar) { - int saw_tick = 0; - const char *olds = *s; PERL_ARGS_ASSERT_PARSE_IDENT; while (*s < PL_bufend) { @@ -10347,15 +10341,6 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, *(*d)++ = *(*s)++; } while (isWORDCHAR_A(**s) && *d < e); } - else if ( allow_package - && **s == '\'' - && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8)) - { - *(*d)++ = ':'; - *(*d)++ = ':'; - (*s)++; - saw_tick++; - } else if (allow_package && **s == ':' && (*s)[1] == ':' /* Disallow things like Foo::$bar. For the curious, this is * the code path that triggers the "Bad name after" warning @@ -10368,66 +10353,24 @@ S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, else break; } - if (UNLIKELY(saw_tick && tick_warn && ckWARN2_d(WARN_SYNTAX, WARN_DEPRECATED__APOSTROPHE_AS_PACKAGE_SEPARATOR))) { - if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { - char *this_d; - char *d2; - Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */ - d2 = this_d; - SAVEFREEPV(this_d); - - Perl_warner(aTHX_ packWARN2(WARN_SYNTAX, WARN_DEPRECATED__APOSTROPHE_AS_PACKAGE_SEPARATOR), - "Old package separator used in string"); - if (olds[-1] == '#') - *d2++ = olds[-2]; - *d2++ = olds[-1]; - while (olds < *s) { - if (*olds == '\'') { - *d2++ = '\\'; - *d2++ = *olds++; - } - else - *d2++ = *olds++; - } - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "\t(Did you mean \"%" UTF8f "\" instead?)\n", - UTF8fARG(is_utf8, d2-this_d, this_d)); - } - else { - Perl_warner(aTHX_ packWARN2(WARN_SYNTAX, WARN_DEPRECATED__APOSTROPHE_AS_PACKAGE_SEPARATOR), - "Old package separator \"'\" deprecated"); - } - } return; } -/* Returns a NUL terminated string, with the length of the string written to - *slp - - scan_word6() may be removed once ' in names is removed. - */ char * -Perl_scan_word6(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp, bool warn_tick) +Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { + PERL_ARGS_ASSERT_SCAN_WORD; + char *d = dest; char * const e = d + destlen - 3; /* two-character token, ending NUL */ bool is_utf8 = cBOOL(UTF); - PERL_ARGS_ASSERT_SCAN_WORD6; - - parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, warn_tick); + parse_ident(&s, &d, e, allow_package, is_utf8, TRUE); *d = '\0'; *slp = d - dest; return s; } -char * -Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) -{ - PERL_ARGS_ASSERT_SCAN_WORD; - return scan_word6(s, dest, destlen, allow_package, slp, FALSE); -} - /* scan s and extract an identifier ($var) from it if possible * into dest. * XXX: This function has subtle implications on parsing, and @@ -10463,7 +10406,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) Perl_croak(aTHX_ ident_var_zero_multi_digit); } else { /* See if it is a "normal" identifier */ - parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE); + parse_ident(&s, &d, e, 1, is_utf8, FALSE); } *d = '\0'; d = dest; @@ -10588,7 +10531,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) (the later check for } being at the expected point will trap cases where this doesn't pan out.) */ d += is_utf8 ? UTF8SKIP(d) : 1; - parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE); + parse_ident(&s, &d, e, 1, is_utf8, TRUE); *d = '\0'; } else { /* caret word: ${^Foo} ${^CAPTURE[0]} */ @@ -11535,7 +11478,7 @@ S_scan_inputsymbol(pTHX_ char *start) if (*d == '$' && d[1]) d++; /* allow or */ - while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') { + while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == ':') { d += UTF ? UTF8SKIP(d) : 1; } @@ -13883,7 +13826,7 @@ Perl_parse_label(pTHX_ U32 flags) t = s = PL_bufptr; if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) goto no_label; - t = scan_word6(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen, FALSE); + t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen); if (word_takes_any_delimiter(s, wlen)) goto no_label; bufptr_pos = s - SvPVX(PL_linestr);