diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | lib/feature.pm | 65 | ||||
| -rw-r--r-- | perl.c | 6 | ||||
| -rw-r--r-- | perl_keyword.pl | 2 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | pod/perlop.pod | 4 | ||||
| -rw-r--r-- | pod/perlrun.pod | 10 | ||||
| -rw-r--r-- | sv.c | 1 | ||||
| -rw-r--r-- | t/lib/feature/err | 66 | ||||
| -rw-r--r-- | t/lib/feature/nonesuch | 10 | ||||
| -rw-r--r-- | t/lib/warnings/op | 1 | ||||
| -rw-r--r-- | t/op/dor.t | 15 | ||||
| -rw-r--r-- | t/run/switches.t | 27 | ||||
| -rw-r--r-- | toke.c | 16 |
17 files changed, 188 insertions, 42 deletions
@@ -2969,6 +2969,7 @@ t/lib/dprof/test7_v Perl code profiler tests t/lib/dprof/test8_t Perl code profiler tests t/lib/dprof/test8_v Perl code profiler tests t/lib/dprof/V.pm Perl code profiler tests +t/lib/feature/err Tests for enabling/disabling err feature t/lib/feature/nonesuch Tests for enabling/disabling nonexistent feature t/lib/feature/say Tests for enabling/disabling say feature t/lib/feature/smartmatch Tests for enabling/disabling smartmatch feature diff --git a/embedvar.h b/embedvar.h index ee65be4167..ca344b81c9 100644 --- a/embedvar.h +++ b/embedvar.h @@ -307,6 +307,7 @@ #define PL_maxsysfd (vTHX->Imaxsysfd) #define PL_mess_sv (vTHX->Imess_sv) #define PL_min_intro_pending (vTHX->Imin_intro_pending) +#define PL_minus_E (vTHX->Iminus_E) #define PL_minus_F (vTHX->Iminus_F) #define PL_minus_a (vTHX->Iminus_a) #define PL_minus_c (vTHX->Iminus_c) @@ -586,6 +587,7 @@ #define PL_Imaxsysfd PL_maxsysfd #define PL_Imess_sv PL_mess_sv #define PL_Imin_intro_pending PL_min_intro_pending +#define PL_Iminus_E PL_minus_E #define PL_Iminus_F PL_minus_F #define PL_Iminus_a PL_minus_a #define PL_Iminus_c PL_minus_c diff --git a/global.sym b/global.sym index 376f23e36d..13dacb0720 100644 --- a/global.sym +++ b/global.sym @@ -74,6 +74,7 @@ Perl_sv_catpvf_mg_nocontext Perl_sv_setpvf_mg_nocontext Perl_fprintf_nocontext Perl_printf_nocontext +Perl_gv_const_sv Perl_cv_const_sv Perl_cv_undef Perl_cx_dump diff --git a/intrpvar.h b/intrpvar.h index e45e23dff0..04ea137362 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -38,6 +38,7 @@ PERLVAR(Iminus_l, bool) PERLVAR(Iminus_a, bool) PERLVAR(Iminus_F, bool) PERLVAR(Idoswitches, bool) +PERLVAR(Iminus_E, bool) /* =head1 Global Variables diff --git a/lib/feature.pm b/lib/feature.pm index fe549944bc..345b288a2a 100644 --- a/lib/feature.pm +++ b/lib/feature.pm @@ -8,6 +8,11 @@ my %feature = ( switch => 'feature_switch', "~~" => "feature_~~", say => "feature_say", + err => "feature_err", +); + +my %feature_bundle = ( + "5.10" => [qw(switch ~~ say err)], ); @@ -31,13 +36,13 @@ feature - Perl pragma to enable new syntactic features =head1 SYNOPSIS - use feature 'switch'; + use feature qw(switch say); given ($foo) { - when (1) { print "\$foo == 1\n" } - when ([2,3]) { print "\$foo == 2 || \$foo == 3\n" } - when (/^a[bc]d$/) { print "\$foo eq 'abd' || \$foo eq 'acd'\n" } - when ($_ > 100) { print "\$foo > 100\n" } - default { print "None of the above\n" } + when (1) { say "\$foo == 1" } + when ([2,3]) { say "\$foo == 2 || \$foo == 3" } + when (/^a[bc]d$/) { say "\$foo eq 'abd' || \$foo eq 'acd'" } + when ($_ > 100) { say "\$foo > 100" } + default { say "None of the above" } } =head1 DESCRIPTION @@ -69,6 +74,22 @@ C<say> function from here to the end of the enclosing BLOCK. See L<perlfunc/say> for details. +=head2 the 'err' feature + +C<use feature 'err'> tells the compiler to enable the C<err> +operator from here to the end of the enclosing BLOCK. + +C<err> is a low-precedence variant of the C<//> operator: +see C<perlop> for details. + +=head1 FEATURE BUNDLES + +It's possible to load a whole slew of features in one go, using +a I<feature bundle>. The name of a feature bundle is prefixed with +a colon, to distinguish it from an actual feature. At present, the +only feature bundle is C<use feature ":5.10">, which is equivalent +to C<use feature qw(switch ~~ say err)>. + =cut sub import { @@ -82,6 +103,16 @@ sub import { } while (@_) { my $name = shift(@_); + if ($name =~ /^:(.*)/) { + if (!exists $feature_bundle{$1}) { + require Carp; + Carp->import("croak"); + croak(sprintf('Feature bundle "%s" is not supported by Perl %vd', + $1, $^V)); + } + unshift @_, @{$feature_bundle{$1}}; + next; + } if (!exists $feature{$name}) { require Carp; Carp->import("croak"); @@ -96,7 +127,23 @@ sub unimport { my $class = shift; # A bare C<no feature> should disable *all* features - for my $name (@_) { + if (!@_) { + delete @^H{ values(%feature) }; + return; + } + + while (@_) { + my $name = shift; + if ($name =~ /^:(.*)/) { + if (!exists $feature_bundle{$1}) { + require Carp; + Carp->import("croak"); + croak(sprintf('Feature bundle "%s" is not supported by Perl %vd', + $1, $^V)); + } + unshift @_, @{$feature_bundle{$1}}; + next; + } if (!exists($feature{$name})) { require Carp; Carp->import("croak"); @@ -107,10 +154,6 @@ sub unimport { delete $^H{$feature{$name}}; } } - - if(!@_) { - delete @^H{ values(%feature) }; - } } 1; @@ -1665,6 +1665,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; + case 'E': + PL_minus_E = TRUE; + /* FALL THROUGH */ case 'e': #ifdef MACOS_TRADITIONAL /* ignore -e for Dev:Pseudo argument */ @@ -1683,7 +1686,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } else - Perl_croak(aTHX_ "No code specified for -e"); + Perl_croak(aTHX_ "No code specified for -%c", *s); sv_catpv(PL_e_script, "\n"); break; @@ -2825,6 +2828,7 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ "-d[:debugger] run program under debugger", "-D[number/list] set debugging flags (argument is a bit mask or alphabets)", "-e program one line of program (several -e's allowed, omit programfile)", +"-E program like -e, but enables all optional features", "-f don't do $sitelib/sitecustomize.pl at startup", "-F/pattern/ split() pattern for -a switch (//'s are optional)", "-i[extension] edit <> files in place (makes backup if extension supplied)", diff --git a/perl_keyword.pl b/perl_keyword.pl index d0471f6891..904bb59e79 100644 --- a/perl_keyword.pl +++ b/perl_keyword.pl @@ -43,6 +43,8 @@ my %feature_kw = ( break => 'switch', say => 'say', + + err => 'err', ); my %pos = map { ($_ => 1) } @pos; @@ -412,6 +412,8 @@ END_EXTERN_C #define PL_mess_sv (*Perl_Imess_sv_ptr(aTHX)) #undef PL_min_intro_pending #define PL_min_intro_pending (*Perl_Imin_intro_pending_ptr(aTHX)) +#undef PL_minus_E +#define PL_minus_E (*Perl_Iminus_E_ptr(aTHX)) #undef PL_minus_F #define PL_minus_F (*Perl_Iminus_F_ptr(aTHX)) #undef PL_minus_a diff --git a/pod/perlop.pod b/pod/perlop.pod index db105e32ae..c2fba59d65 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -838,7 +838,9 @@ Then again, you could always use parentheses. Binary "err" is equivalent to C<//>--it's just like binary "or", except it tests its left argument's definedness instead of its truth. There are two ways to remember "err": either because many functions return C<undef> on an B<err>or, -or as a sort of correction: C<$a=($b err 'default')> +or as a sort of correction: C<$a=($b err 'default')>. This keyword +is only available when the 'err' feature is enabled: see L<feature> +for more information. Binary "xor" returns the exclusive-OR of the two surrounding expressions. It cannot short circuit, of course. diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 06f90521e6..d49707479b 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -15,7 +15,7 @@ B<perl> S<[ B<-sTtuUWX> ]> S<[ B<-S> ]> S<[ B<-x>[I<dir>] ]> S<[ B<-i>[I<extension>] ]> - S<[ B<-e> I<'command'> ] [ B<--> ] [ I<programfile> ] [ I<argument> ]...> + S<[ B<-eE> I<'command'> ] [ B<--> ] [ I<programfile> ] [ I<argument> ]...> =head1 DESCRIPTION @@ -30,7 +30,7 @@ places: =item 1. -Specified line by line via B<-e> switches on the command line. +Specified line by line via B<-e> or B<-E> switches on the command line. =item 2. @@ -448,6 +448,12 @@ will not look for a filename in the argument list. Multiple B<-e> commands may be given to build up a multi-line script. Make sure to use semicolons where you would in a normal program. +=item B<-E> I<commandline> +X<-E> + +behaves just like B<-e>, except that it implicitly enables all +optional features (in the main compilation unit). See L<feature>. + =item B<-f> X<-f> @@ -10232,6 +10232,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_minus_p = proto_perl->Iminus_p; PL_minus_l = proto_perl->Iminus_l; PL_minus_a = proto_perl->Iminus_a; + PL_minus_E = proto_perl->Iminus_E; PL_minus_F = proto_perl->Iminus_F; PL_doswitches = proto_perl->Idoswitches; PL_dowarn = proto_perl->Idowarn; diff --git a/t/lib/feature/err b/t/lib/feature/err new file mode 100644 index 0000000000..638b5a68ea --- /dev/null +++ b/t/lib/feature/err @@ -0,0 +1,66 @@ +Check the lexical scoping of the err keyword. +(The actual behaviour is tested in t/op/dor.t) + +__END__ +# No err; should be a syntax error. +use warnings; +my $undef err print "Hello!\n"; +EXPECT +Bareword found where operator expected at - line 3, near "$undef err" + (Missing operator before err?) +Unquoted string "err" may clash with future reserved word at - line 3. +syntax error at - line 3, near "$undef err " +Execution of - aborted due to compilation errors. +######## +# With err, should work +use warnings; +use feature "err"; +my $undef err print "Hello", "world"; +EXPECT +Helloworld +######## +# With err, should work in eval too +use warnings; +use feature "err"; +eval q(my $undef err print "Hello", "world"); +EXPECT +Helloworld +######## +# feature out of scope; should be a syntax error. +use warnings; +{ use feature 'err'; } +my $undef err print "Hello", "world"; +EXPECT +Bareword found where operator expected at - line 4, near "$undef err" + (Missing operator before err?) +Unquoted string "err" may clash with future reserved word at - line 4. +syntax error at - line 4, near "$undef err " +Execution of - aborted due to compilation errors. +######## +# 'no feature' should work +use warnings; +use feature 'err'; +my $undef err print "Hello", "world"; +no feature; +my $undef2 err "Hello", "world"; +EXPECT +Bareword found where operator expected at - line 6, near "$undef2 err" + (Missing operator before err?) +Unquoted string "err" may clash with future reserved word at - line 6. +String found where operator expected at - line 6, near "err "Hello"" + (Do you need to predeclare err?) +syntax error at - line 6, near "$undef2 err " +Execution of - aborted due to compilation errors. +######## +# 'no feature "err"' should work too +use warnings; +use feature 'err'; +my $undef err print "Hello", "world"; +no feature 'err'; +$undef err print "Hello", "world"; +EXPECT +Bareword found where operator expected at - line 6, near "$undef err" + (Missing operator before err?) +Unquoted string "err" may clash with future reserved word at - line 6. +syntax error at - line 6, near "$undef err " +Execution of - aborted due to compilation errors. diff --git a/t/lib/feature/nonesuch b/t/lib/feature/nonesuch index 1de44f621b..0de975ad54 100644 --- a/t/lib/feature/nonesuch +++ b/t/lib/feature/nonesuch @@ -10,3 +10,13 @@ no feature "nonesuch"; EXPECT OPTIONS regex ^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 +######## +use feature ":nonesuch"; +EXPECT +OPTIONS regex +^Feature bundle "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 +######## +no feature ":nonesuch"; +EXPECT +OPTIONS regex +^Feature bundle "nonesuch" is not supported by Perl [v0-9.]+ at - line 1 diff --git a/t/lib/warnings/op b/t/lib/warnings/op index c39a7b2fd9..ca92412d62 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -679,6 +679,7 @@ Value of readdir() operator can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc'; +use feature 'err'; open FH, "<abc"; $_ = <FH> err $_ = 1; ($_ = <FH>) // ($_ = 1); diff --git a/t/op/dor.t b/t/op/dor.t index 079631a31d..04e0f7d8e7 100644 --- a/t/op/dor.t +++ b/t/op/dor.t @@ -8,9 +8,10 @@ BEGIN { } package main; +use feature "err"; require './test.pl'; -plan( tests => 41 ); +plan( tests => 35 ); my($x); @@ -82,15 +83,3 @@ like( $@, qr/^Search pattern not terminated/ ); is(0 // 2, 0, ' // : left-hand operand not optimized away'); is('' // 2, '', ' // : left-hand operand not optimized away'); is(undef // 2, 2, ' // : left-hand operand optimized away'); - -# [perl #32347] err should be a weak keyword - -package weakerr; - -sub err { "<@_>" } -::is( (shift() err 42), 42, 'err as an operator' ); -::is( (shift err 42), 42, 'err as an operator, with ambiguity' ); -::is( (err 2), "<2>", 'err as a function without parens' ); -::is( err(2, 3), "<2 3>", 'err as a function with parens' ); -::is( err(), "<>", 'err as a function without arguments' ); -::is( err, "<>", 'err as a function without parens' ); diff --git a/t/run/switches.t b/t/run/switches.t index a63c54b9f5..f654486467 100644 --- a/t/run/switches.t +++ b/t/run/switches.t @@ -1,7 +1,7 @@ #!./perl -w # Tests for the command-line switches: -# -0, -c, -l, -s, -m, -M, -V, -v, -h, -z, -i +# -0, -c, -l, -s, -m, -M, -V, -v, -h, -z, -i, -E # Some switches have their own tests, see MANIFEST. BEGIN { @@ -11,7 +11,7 @@ BEGIN { require "./test.pl"; -plan(tests => 26); +plan(tests => 30); use Config; @@ -282,3 +282,26 @@ __EOF__ "foo yada dada:bada foo bing:king kong foo", "-i backup file"); } + +# Tests for -E + +$r = runperl( + switches => [ '-E', '"say q(Hello, world!)"'] +); +is( $r, "Hello, world!\n", "-E say" ); + + +$r = runperl( + switches => [ '-E', '"undef err say q(Hello, world!)"'] +); +is( $r, "Hello, world!\n", "-E err" ); + +$r = runperl( + switches => [ '-E', '"undef ~~ undef and say q(Hello, world!)"'] +); +is( $r, "Hello, world!\n", "-E ~~" ); + +$r = runperl( + switches => [ '-E', '"given(undef) {when(undef) { say q(Hello, world!)"}}'] +); +is( $r, "Hello, world!\n", "-E given" ); @@ -459,7 +459,7 @@ S_missingterm(pTHX_ char *s) #define FEATURE_IS_ENABLED(name, namelen) \ ((0 != (PL_hints & HINT_LOCALIZE_HH)) \ - && feature_is_enabled(name, namelen)) + && feature_is_enabled(name, namelen) ) /* * S_feature_is_enabled * Check whether the named feature is enabled. @@ -2727,6 +2727,8 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr,"our @F=split(' ');"); } } + if (PL_minus_E) + sv_catpv(PL_linestr,"use feature ':5.10';"); sv_catpvn(PL_linestr, "\n", 1); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -4198,16 +4200,6 @@ Perl_yylex(pTHX) { tmp = 0; /* any sub overrides "weak" keyword */ } - else if (gv && !gvp - && tmp == -KEY_err - && GvCVu(gv) - && PL_expect != XOPERATOR - && PL_expect != XTERMORDORDOR) - { - /* any sub overrides the "err" keyword, except when really an - * operator is expected */ - tmp = 0; - } else { /* no override */ tmp = -tmp; if (tmp == KEY_dump && ckWARN(WARN_MISC)) { @@ -6098,7 +6090,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'r': if (name[2] == 'r') { /* err */ - return -KEY_err; + return (FEATURE_IS_ENABLED("err", 3) ? -KEY_err : 0); } goto unknown; |