This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
provide a test for the PL_check mis-behaviour
authorTony Cook <tony@develop-help.com>
Sun, 8 Dec 2019 23:51:19 +0000 (10:51 +1100)
committerTony Cook <tony@develop-help.com>
Thu, 12 Dec 2019 00:35:20 +0000 (11:35 +1100)
Nicholas Clark's fix for IO makes the test in niner's patch
meaningless, so test it separately.

MANIFEST
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/Hoisted.pm [new file with mode: 0644]
ext/XS-APItest/t/pl_check.t [new file with mode: 0644]

index 387ec38..b3b40fb 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4438,6 +4438,7 @@ ext/XS-APItest/t/handy08.t        XS::APItest: tests for handy.h
 ext/XS-APItest/t/handy09.t     XS::APItest: tests for handy.h
 ext/XS-APItest/t/handy_base.pl XS::APItest: tests for handy.h
 ext/XS-APItest/t/hash.t                XS::APItest: tests for hash related APIs
+ext/XS-APItest/t/Hoisted.pm    used by pl_check.t
 ext/XS-APItest/t/join_with_space.t     test op_convert_list
 ext/XS-APItest/t/keyword_multiline.t   test keyword plugin parsing across lines
 ext/XS-APItest/t/keyword_plugin.t      test keyword plugin mechanism
@@ -4467,6 +4468,7 @@ ext/XS-APItest/t/op_list.t        test OP list construction API
 ext/XS-APItest/t/overload.t    XS::APItest: tests for overload related APIs
 ext/XS-APItest/t/pad_scalar.t  Test pad_findmy_* functions
 ext/XS-APItest/t/peep.t                test PL_peepp/PL_rpeepp
+ext/XS-APItest/t/pl_check.t    Test PL_check thread safety
 ext/XS-APItest/t/pmflag.t      Test removal of Perl_pmflag()
 ext/XS-APItest/t/postinc.t     test op_lvalue()
 ext/XS-APItest/t/printf.t      XS::APItest extension
index fcaea38..f682784 100644 (file)
@@ -742,6 +742,26 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
     }
 }
 
+static OP *
+hoist_pp_nextstate(pTHX)
+{
+    dVAR;
+    COP *old_curcop = PL_curcop;
+    OP *next = PL_ppaddr[PL_op->op_type](aTHX);
+    PL_curcop = old_curcop;
+    return next;
+}
+
+static OP *
+hoist_ck_lineseq(pTHX_ OP *o)
+{
+    OP *kid = cBINOPo->op_first;
+    for (; kid; kid = OpSIBLING(kid))
+       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+           kid->op_ppaddr = hoist_pp_nextstate;
+    return o;
+}
+
 /** RPN keyword parser **/
 
 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -4497,6 +4517,16 @@ PerlIO_stdin()
 FILE *
 PerlIO_exportFILE(PerlIO *f, const char *mode)
 
+SV *
+create_hoisted_subs(const char *code)
+    CODE:
+       OP *(*old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
+       PL_check[OP_LINESEQ] = hoist_ck_lineseq;
+       RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
+       PL_check[OP_LINESEQ] = old_ck_lineseq;
+    OUTPUT:
+       RETVAL
+
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
 int
diff --git a/ext/XS-APItest/t/Hoisted.pm b/ext/XS-APItest/t/Hoisted.pm
new file mode 100644 (file)
index 0000000..a92e26e
--- /dev/null
@@ -0,0 +1,23 @@
+package Hoisted;
+use XS::APItest;
+use Carp;
+
+XS::APItest::create_hoisted_subs(<<'CODE');
+sub getline {
+    @_ == 1 or croak 'usage: $io->getline()';
+    my $this = shift;
+    return scalar <$this>;
+}
+
+sub getlines {
+    @_ == 1 or croak 'usage: $io->getlines()';
+    wantarray or
+       croak 'Can\'t call $io->getlines in a scalar context, use $io->getline';
+    my $this = shift;
+    return <$this>;
+}
+
+1;
+CODE
+
+1;
diff --git a/ext/XS-APItest/t/pl_check.t b/ext/XS-APItest/t/pl_check.t
new file mode 100644 (file)
index 0000000..87f9d89
--- /dev/null
@@ -0,0 +1,31 @@
+#!perl
+use strict;
+use Config;
+
+# this doesn't work with Test::More
+BEGIN {
+    require '../../t/test.pl';
+}
+
+use threads;
+
+
+$Config{usethreads}
+  or plan skip_all => "test requires threads";
+
+# do not use XS::APItest in this test
+
+use constant thread_count => 20;
+
+plan tests => thread_count;
+
+local $::TODO = "PL_check isn't thread-safe";
+push @INC, "t";
+my @threads;
+for (1..thread_count) {
+    push @threads, threads->create(sub {
+        require Hoisted;
+        return 1;
+    });
+}
+ok $_->join for @threads;