summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--feature.h35
-rw-r--r--lib/feature.pm20
-rw-r--r--op.c4
-rw-r--r--op.h1
-rw-r--r--pod/perldelta.pod8
-rw-r--r--pp_ctl.c65
-rwxr-xr-xregen/feature.pl14
-rw-r--r--t/comp/require.t185
8 files changed, 305 insertions, 27 deletions
diff --git a/feature.h b/feature.h
index 08061e12c8..900a1b990e 100644
--- a/feature.h
+++ b/feature.h
@@ -22,16 +22,17 @@
#define FEATURE_FC_BIT 0x0080
#define FEATURE_INDIRECT_BIT 0x0100
#define FEATURE_ISA_BIT 0x0200
-#define FEATURE_MULTIDIMENSIONAL_BIT 0x0400
-#define FEATURE_POSTDEREF_QQ_BIT 0x0800
-#define FEATURE_REFALIASING_BIT 0x1000
-#define FEATURE_SAY_BIT 0x2000
-#define FEATURE_SIGNATURES_BIT 0x4000
-#define FEATURE_STATE_BIT 0x8000
-#define FEATURE_SWITCH_BIT 0x10000
-#define FEATURE_TRY_BIT 0x20000
-#define FEATURE_UNIEVAL_BIT 0x40000
-#define FEATURE_UNICODE_BIT 0x80000
+#define FEATURE_MODULE_TRUE_BIT 0x0400
+#define FEATURE_MULTIDIMENSIONAL_BIT 0x0800
+#define FEATURE_POSTDEREF_QQ_BIT 0x1000
+#define FEATURE_REFALIASING_BIT 0x2000
+#define FEATURE_SAY_BIT 0x4000
+#define FEATURE_SIGNATURES_BIT 0x8000
+#define FEATURE_STATE_BIT 0x10000
+#define FEATURE_SWITCH_BIT 0x20000
+#define FEATURE_TRY_BIT 0x40000
+#define FEATURE_UNIEVAL_BIT 0x80000
+#define FEATURE_UNICODE_BIT 0x100000
#define FEATURE_BUNDLE_DEFAULT 0
#define FEATURE_BUNDLE_510 1
@@ -151,6 +152,13 @@
FEATURE_IS_ENABLED_MASK(FEATURE___SUB___BIT)) \
)
+#define FEATURE_MODULE_TRUE_IS_ENABLED \
+ ( \
+ CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_537 \
+ || (CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
+ FEATURE_IS_ENABLED_MASK(FEATURE_MODULE_TRUE_BIT)) \
+ )
+
#define FEATURE_REFALIASING_IS_ENABLED \
( \
CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM && \
@@ -333,7 +341,12 @@ S_magic_sethint_feature(pTHX_ SV *keysv, const char *keypv, STRLEN keylen,
return;
case 'm':
- if (keylen == sizeof("feature_more_delims")-1
+ if (keylen == sizeof("feature_module_true")-1
+ && memcmp(subf+1, "odule_true", keylen - sizeof("feature_")) == 0) {
+ mask = FEATURE_MODULE_TRUE_BIT;
+ break;
+ }
+ else if (keylen == sizeof("feature_more_delims")-1
&& memcmp(subf+1, "ore_delims", keylen - sizeof("feature_")) == 0) {
mask = FEATURE_MORE_DELIMS_BIT;
break;
diff --git a/lib/feature.pm b/lib/feature.pm
index 523fe48d97..ae6d486028 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -4,8 +4,7 @@
# Any changes made here will be lost!
package feature;
-
-our $VERSION = '1.76';
+our $VERSION = '1.77';
our %feature = (
fc => 'feature_fc',
@@ -20,6 +19,7 @@ our %feature = (
evalbytes => 'feature_evalbytes',
signatures => 'feature_signatures',
current_sub => 'feature___SUB__',
+ module_true => 'feature_module_true',
refaliasing => 'feature_refaliasing',
postderef_qq => 'feature_postderef_qq',
unicode_eval => 'feature_unieval',
@@ -37,8 +37,8 @@ our %feature_bundle = (
"5.23" => [qw(bareword_filehandles current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)],
"5.27" => [qw(bareword_filehandles bitwise current_sub evalbytes fc indirect multidimensional postderef_qq say state switch unicode_eval unicode_strings)],
"5.35" => [qw(bareword_filehandles bitwise current_sub evalbytes fc isa postderef_qq say signatures state unicode_eval unicode_strings)],
- "5.37" => [qw(bitwise current_sub evalbytes fc isa postderef_qq say signatures state unicode_eval unicode_strings)],
- "all" => [qw(bareword_filehandles bitwise current_sub declared_refs defer evalbytes extra_paired_delimiters fc indirect isa multidimensional postderef_qq refaliasing say signatures state switch try unicode_eval unicode_strings)],
+ "5.37" => [qw(bitwise current_sub evalbytes fc isa module_true postderef_qq say signatures state unicode_eval unicode_strings)],
+ "all" => [qw(bareword_filehandles bitwise current_sub declared_refs defer evalbytes extra_paired_delimiters fc indirect isa module_true multidimensional postderef_qq refaliasing say signatures state switch try unicode_eval unicode_strings)],
"default" => [qw(bareword_filehandles indirect multidimensional)],
);
@@ -867,6 +867,14 @@ The complete list of accepted paired delimiters as of Unicode 14.0 is:
🢫 🢪 U+1F8AB, U+1F8AA RIGHT/LEFTWARDS FRONT-TILTED SHADOWED WHITE
ARROW
+=head2 The 'module_true' feature
+
+This feature removes the need to return a true value at the end of a module
+loaded with C<require> or C<use>. Any errors during compilation will cause
+failures, but reaching the end of the module when this feature is in effect
+will prevent C<perl> from throwing an exception that the module "did not return
+a true value".
+
=head1 FEATURE BUNDLES
It's possible to load multiple features together, using
@@ -944,8 +952,8 @@ The following feature bundles are available:
state unicode_eval unicode_strings
:5.38 bitwise current_sub evalbytes fc isa
- postderef_qq say signatures state
- unicode_eval unicode_strings
+ module_true postderef_qq say signatures
+ state unicode_eval unicode_strings
The C<:default> bundle represents the feature set that is enabled before
any C<use feature> or C<no feature> declaration.
diff --git a/op.c b/op.c
index 481158db3f..8849369944 100644
--- a/op.c
+++ b/op.c
@@ -5225,6 +5225,10 @@ OP *
Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
{
if (type < 0) type = -type, flags |= OPf_SPECIAL;
+ if (type == OP_RETURN) {
+ if (FEATURE_MODULE_TRUE_IS_ENABLED)
+ flags |= OPf_SPECIAL;
+ }
if (!o || o->op_type != OP_LIST)
o = force_list(o, FALSE);
else
diff --git a/op.h b/op.h
index ec3e1204a3..12f0c5ce2d 100644
--- a/op.h
+++ b/op.h
@@ -161,6 +161,7 @@ Deprecated. Use C<GIMME_V> instead.
/* On OP_DUMP, has no label */
/* On OP_UNSTACK, in a C-style for loop */
/* On OP_READLINE, it's for <<>>, not <> */
+ /* On OP_RETURN, module_true is in effect */
/* There is no room in op_flags for this one, so it has its own bit-
field member (op_folded) instead. The flag is only used to tell
op_convert_list to set op_folded. */
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 6a1d6da11d..f641641187 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -115,6 +115,14 @@ release manager will have to investigate the situation carefully.)
=item *
+Support for RFC-18, C<use feature "module_true";> has been added to
+the default feature bundle for 5.37 and later. It may also be used
+explicitly. When enabled inside of a module the module does not need
+to return true explicitly, and in fact the return will be forced to
+a simple true value regardless of what it originally was.
+
+=item *
+
XXX Remove this section if not applicable.
=back
diff --git a/pp_ctl.c b/pp_ctl.c
index ee560a4c1e..6b00867563 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4834,6 +4834,7 @@ PP(pp_leaveeval)
PERL_CONTEXT *cx;
OP *retop;
int failed;
+ bool override_return = FALSE; /* is feature 'module_true' in effect? */
CV *evalcv;
bool keep;
@@ -4845,8 +4846,55 @@ PP(pp_leaveeval)
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
- /* did require return a false value? */
- failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
+ if (is_require) {
+ /* We are in an require. Check if use feature 'module_true' is enabled,
+ * and if so later on correct any returns from the require. */
+
+ /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
+ * and the parse tree will look different for either case.
+ * so find the right op to check later */
+ if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
+ if (PL_op->op_flags & OPf_SPECIAL)
+ override_return = true;
+ }
+ else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
+ COP *old_pl_curcop = PL_curcop;
+ OP *check = cUNOPx(PL_op)->op_first;
+
+ /* ok, we found something to check, we need to scan through
+ * it and find the last OP_NEXTSTATE it contains and then read the
+ * feature state out of the COP data it contains.
+ */
+ if (check) {
+ const OP *kid = cLISTOPx(check)->op_first;
+ const OP *last_state = NULL;
+
+ for (; kid; kid = OpSIBLING(kid)) {
+ if (
+ OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
+ || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
+ ){
+ last_state = kid;
+ }
+ }
+ if (last_state) {
+ PL_curcop = cCOPx(last_state);
+ if (FEATURE_MODULE_TRUE_IS_ENABLED) {
+ override_return = TRUE;
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ } else {
+ NOT_REACHED; /* NOTREACHED */
+ }
+ PL_curcop = old_pl_curcop;
+ }
+ }
+
+ /* we might override this later if 'module_true' is enabled */
+ failed = is_require
&& !(gimme == G_SCALAR
? SvTRUE_NN(*PL_stack_sp)
: PL_stack_sp > oldsp);
@@ -4876,6 +4924,19 @@ PP(pp_leaveeval)
#endif
CvDEPTH(evalcv) = 0;
+ if (override_return) {
+ /* make sure that we use a standard return when feature 'module_load'
+ * is enabled. Returns from require are problematic (consider what happens
+ * when it is called twice) */
+ if (gimme == G_SCALAR) {
+ /* this following is an optimization of POPs()/PUSHs().
+ * and does the same thing with less bookkeeping */
+ *PL_stack_sp = &PL_sv_yes;
+ }
+ assert(gimme == G_VOID || gimme == G_SCALAR);
+ failed = 0;
+ }
+
/* pop the CXt_EVAL, and if a require failed, croak */
S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
diff --git a/regen/feature.pl b/regen/feature.pl
index 11cfbcfd0c..031f1a8ad6 100755
--- a/regen/feature.pl
+++ b/regen/feature.pl
@@ -43,6 +43,7 @@ my %feature = (
try => 'try',
defer => 'defer',
extra_paired_delimiters => 'more_delims',
+ module_true => 'module_true',
);
# NOTE: If a feature is ever enabled in a non-contiguous range of Perl
@@ -62,7 +63,7 @@ use constant V5_35 => sort grep {; $_ ne 'switch'
&& $_ ne 'indirect'
&& $_ ne 'multidimensional' } +V5_27, qw{isa signatures};
-use constant V5_37 => sort grep {; $_ ne 'bareword_filehandles' } +V5_35;
+use constant V5_37 => sort grep {; $_ ne 'bareword_filehandles' } +V5_35, qw{module_true};
#
# when updating features please also update the Pod entry for L</"FEATURES CHEAT SHEET">
@@ -497,8 +498,7 @@ read_only_bottom_close_and_rename($h);
__END__
package feature;
-
-our $VERSION = '1.76';
+our $VERSION = '1.77';
FEATURES
@@ -1287,6 +1287,14 @@ The complete list of accepted paired delimiters as of Unicode 14.0 is:
🢫 🢪 U+1F8AB, U+1F8AA RIGHT/LEFTWARDS FRONT-TILTED SHADOWED WHITE
ARROW
+=head2 The 'module_true' feature
+
+This feature removes the need to return a true value at the end of a module
+loaded with C<require> or C<use>. Any errors during compilation will cause
+failures, but reaching the end of the module when this feature is in effect
+will prevent C<perl> from throwing an exception that the module "did not return
+a true value".
+
=head1 FEATURE BUNDLES
It's possible to load multiple features together, using
diff --git a/t/comp/require.t b/t/comp/require.t
index f79480f194..3c64251b58 100644
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -1,5 +1,9 @@
#!./perl
+# NOTE this script messes with the perl debugger flags, if you run
+# it under the perl debugger (perl -d) it might not work as expected.
+# Look for code related to $^P below and adjust accordingly.
+
BEGIN {
chdir 't' if -d 't';
@INC = '.';
@@ -16,8 +20,12 @@ sub do_require {
# don't make this lexical
$i = 1;
-my @files_to_delete = qw (bleah.pm bleah.do bleah.flg urkkk.pm urkkk.pmc
-krunch.pm krunch.pmc whap.pm whap.pmc);
+our @module_true_tests; # this is set up in a BEGIN later on.
+our $module_true_test_count; # this is set up in a BEGIN later on.
+my @files_to_delete = qw (bleah.pm bleah.do bleah.flg blorn.pm blunge.pm
+urkkk.pm urkkk.pmc krunch.pm krunch.pmc whap.pm whap.pmc
+Demo1.pm Demo2.pm Demo3.pm Demo4.pm);
+push @files_to_delete, "$_->[0].pm" for @module_true_tests;
# there may be another copy of this test script running, or the files may
# just not have been deleted at the end of the last run; if the former, we
@@ -31,9 +39,8 @@ if (grep -e, @files_to_delete) {
sleep 20;
}
-
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 58;
+my $total_tests = 58 + $module_true_test_count;
if ($Is_UTF8) { $total_tests -= 3; }
print "1..$total_tests\n";
@@ -348,6 +355,174 @@ if (defined &DynaLoader::boot_DynaLoader) {
print "${not}ok $i - require does not localise %^H at run time\n";
}
+
+BEGIN {
+ # These are the test for feature 'module_true', which when in effect
+ # avoids the requirement for a module to return a true value, and
+ # in fact forces the return value to be a simple "true"
+ # (eg, PL_sv_yes, aka 1).
+ # we have a lot of permutations of how this code might trigger, and
+ # etc. so we set up the test set here.
+
+ my @params = (
+ 'v5.37',
+ 'feature ":5.38"',
+ 'feature ":all"',
+ 'feature "module_true"',
+ );
+ my @module_code = (
+ '',
+ 'sub foo {};',
+ 'sub foo {}; 0;',
+ 'sub foo {}; return 0;',
+ 'sub foo {}; return (0,0,0);',
+ 'sub foo {}; return (1,1,1);',
+ 'sub foo {}; (0, return 0);',
+ 'sub foo {}; "some_true_value";',
+ 'sub foo {}; return "some_true_value";',
+ 'sub foo {}; (0, return "some_true_value");',
+ 'sub foo {}; (0, return "some_true_value");',
+ );
+ my @eval_code = (
+ 'use PACK;',
+ 'require PACK;',
+ '$return_val = require PACK;',
+ '@return_val = require PACK;',
+ 'require "PACK.pm";',
+ '$return_val = require "PACK.pm";',
+ '@return_val = require "PACK.pm";',
+ );
+
+ # build a list of tuples. for now this just keeps the test
+ # indent level reasonable for the main test loop, but we could
+ # compute this at BEGIN time and then add the number of tests
+ # to the total count
+ foreach my $debugger_state (0,0xA) {
+ foreach my $param_str (@params) {
+ foreach my $mod_code (@module_code) {
+ foreach my $eval_code (@eval_code) {
+ my $pack_name= sprintf "mttest%d", 0+@module_true_tests;
+ my $eval_code_munged= $eval_code=~s/PACK/$pack_name/r;
+ # this asks the debugger to preserve lines from evals.
+ # it causes nextstate ops to convert to dbstate ops,
+ # and we need to check that we can handle both cases.
+ $eval_code_munged= '$^P = ' . $debugger_state .
+ '; ' . $eval_code_munged
+ if $debugger_state;
+ push @module_true_tests,
+ [$pack_name, $param_str, $mod_code, $eval_code_munged];
+ $module_true_test_count += ($eval_code=~/return_val/ ? 2 : 1);
+ }
+ }
+ }
+ }
+
+ # and more later on
+ $module_true_test_count += 12;
+}
+
+{
+ foreach my $tuple (@module_true_tests) {
+ my ($pack_name, $param_str, $mod_code, $eval_code)= @$tuple;
+
+ write_file("$pack_name.pm","package $pack_name;\nuse $param_str;\n$mod_code\n");
+ %INC = ();
+ # these might be assigned to in the $eval_code
+ my $return_val;
+ my @return_val;
+ my $not = eval "$eval_code 1" ? "" : "not ";
+ $^P = 0; # turn the debugger off after the eval.
+ $i++;
+ print "${not}ok $i - use $param_str did not blow up for `",
+ $mod_code || "#no body", "` via `$eval_code`\n";
+ if ($not) {
+ # we died, show the error:
+ print "# $_\n" for split /\n/, $@;
+ }
+ if ($eval_code=~/\$return_val/) {
+ $not = ($return_val && $return_val eq '1') ? "" : "not ";
+ $i++;
+ print "${not}ok $i - use $param_str ensures scalar return value "
+ . "is simple true value <$return_val>\n";
+ }
+ elsif ($eval_code=~/\@return_val/) {
+ $not = (@return_val && $return_val[0] eq '1') ? "" : "not ";
+ $i++;
+ print "${not}ok $i - use $param_str ensures list return value "
+ . "is simple true value <$return_val[0]>\n";
+ }
+ }
+
+ {
+ write_file('blorn.pm', "package blorn;\nuse v5.37;\nsub foo {};\nno feature 'module_true';\n");
+
+ local $@;
+ my $result = 0;
+ my $not = eval "\$result = require 'blorn.pm'; 1" ? 'not ' : '';
+ $i++;
+ print "${not}ok $i - disabling module_true should not return a true value ($result)\n";
+ $not = $@ =~ /did not return a true value/ ? '' : 'not ';
+ $i++;
+ print "${not}ok $i - ... and should fail to compile without a true return value\n";
+ }
+
+ {
+ write_file('blunge.pm', "package blunge;\nuse feature ':5.38';\n".
+ "sub bar {};\nno feature 'module_true';\n3;\n");
+
+ local $@;
+ my $result = 0;
+ eval "\$result = require 'blunge.pm'; 1";
+ $not = $result == 3 ? '' : 'not ';
+ $i++;
+ print "${not}ok $i - disabling 'module_true' and should not override module's return value ($result)\n";
+ $not = $@ eq '' ? '' : 'not ';
+ $i++;
+ print "${not}ok $i - ... but should compile successfully with a provided return value\n";
+ }
+ for $main::test_mode (1..4) {
+ my $pack= "Demo$main::test_mode";
+ write_file("$pack.pm", sprintf(<<'CODE', $pack)=~s/^#//mgr);
+#package %s;
+#use feature 'module_true';
+#
+#return 1 if $main::test_mode == 1;
+#return 0 if $main::test_mode == 2;
+#
+#{
+# no feature 'module_true';
+# return 0 if $main::test_mode == 3;
+#}
+#no feature 'module_true';
+CODE
+ local $@;
+ my $result = 0;
+ my $ok= eval "\$result = require '$pack.pm'; 1";
+ my $err= $ok ? "" : $@;
+ if ($main::test_mode >= 3) {
+ my $not = $ok ? 'not ' : '';
+ $i++;
+ print "${not}ok $i - in $pack disabling module_true "
+ . "should not return a true value ($result)\n";
+ $not = $err =~ /did not return a true value/ ? '' : 'not ';
+ $i++;
+ print "${not}ok $i - ... and should throw the expected error\n";
+ if ($not) {
+ print "# $_\n" for split /\n/, $err;
+ }
+ } else {
+ my $not = $ok ? '' : 'not ';
+ $i++;
+ print "${not}ok $i - in $pack enabling module_true "
+ . "should not return a true value ($result)\n";
+ $not = $result == 1 ? "" : "not ";
+ $i++;
+ print "${not}ok $i - ... and should return a simple true value\n";
+ }
+ }
+
+}
+
##########################################
# What follows are UTF-8 specific tests. #
# Add generic tests before this point. #
@@ -379,7 +554,7 @@ foreach (sort keys %templates) {
END {
foreach my $file (@files_to_delete) {
- 1 while unlink $file;
+ 1 while unlink $file;
}
}
View Lorry Controller Status