fix occasional op/time.t failure

[p5sagit/p5-mst-13.2.git] / t / op / threads.t

diff --git a/t/op/threads.t b/t/op/threads.t
index 02ae213..165c542 100644 (file)
--- a/t/op/threads.t
+++ b/t/op/threads.t
@@ -1,8 +1,9 @@
 #!./perl
 BEGIN {
      chdir 't' if -d 't';
-     unshift @INC, '../lib';
+     @INC = '../lib';
      require './test.pl';      # for which_perl() etc
+     $| = 1;
 }
 
 use strict;
@@ -13,13 +14,13 @@ BEGIN {
        print "1..0 # Skip: no ithreads\n";
        exit 0;
      }
-     eval 'use threads';
-     if ($@ =~ /dynamic loading not available/) {
-       print "1..0 # Skip: miniperl can't load threads\n";
-       exit 0;
+     if ($ENV{PERL_CORE_MINITEST}) {
+       print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
+       exit 0;
      }
-     plan(3);
+     plan(6);
 }
+use threads;
 
 # test that we don't get:
 # Attempt to free unreferenced scalar: SV 0x40173f3c
@@ -59,3 +60,56 @@ weaken $ref;
 threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
 print "ok";
 EOI
+
+#PR30333 - sort() crash with threads
+sub mycmp { length($b) <=> length($a) }
+
+sub do_sort_one_thread {
+   my $kid = shift;
+   print "# kid $kid before sort\n";
+   my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
+                'hello', 's', 'thisisalongname', '1', '2', '3',
+                'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
+
+   for my $j (1..99999) {
+      for my $k (sort mycmp @list) {}
+   }
+   print "# kid $kid after sort, sleeping 1\n";
+   sleep(1);
+   print "# kid $kid exit\n";
+}
+
+sub do_sort_threads {
+   my $nthreads = shift;
+   my @kids = ();
+   for my $i (1..$nthreads) {
+      my $t = threads->new(\&do_sort_one_thread, $i);
+      print "# parent $$: continue\n";
+      push(@kids, $t);
+   }
+   for my $t (@kids) {
+      print "# parent $$: waiting for join\n";
+      $t->join();
+      print "# parent $$: thread exited\n";
+   }
+}
+
+do_sort_threads(2);        # crashes
+ok(1);
+
+# Change 24643 made the mistake of assuming that CvCONST can only be true on
+# XSUBs. Somehow it can also end up on perl subs.
+fresh_perl_is(<<'EOI', 'ok', { }, 'cloning constant subs');
+use constant x=>1;
+use threads;
+$SIG{__WARN__} = sub{};
+async sub {};
+print "ok";
+EOI
+
+# From a test case by Tim Bunce in
+# http://www.nntp.perl.org/group/perl.perl5.porters/63123
+fresh_perl_is(<<'EOI', 'ok', { }, 'Ensure PL_linestr can be cloned');
+use threads;
+print do 'op/threads_create.pl';
+EOI