Merge pull request #5 from Dual-Life/develop

2.12 Fix Clang macro

Changes

@@ -3,6 +3,9 @@ Revision history for Perl extension threads.
 -
 	-
 
+2.12 Sat Dec 31 17:50:58 2016
+	- Fix Clang macro
+
 2.09 Fri May 20 18:58:20 2016
 	- Document that detached threads suppress the global destruction phase
 

MANIFEST

@@ -19,6 +19,7 @@ t/free2.t
 t/join.t
 t/kill.t
 t/kill2.t
+t/kill3.t
 t/libc.t
 t/list.t
 t/no_threads.t

README

@@ -1,4 +1,4 @@
-threads version 2.09
+threads version 2.12
 ====================
 
 This module exposes interpreter threads to the Perl level.

lib/threads.pm

@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '2.09';
+our $VERSION = '2.12';
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 2.09
+This document describes threads version 2.12
 
 =head1 WARNING
 

t/exit.t

@@ -48,7 +48,7 @@ my $rc = $thr->join();
 ok(! defined($rc), 'Exited: threads->exit()');
 
 
-run_perl(prog => 'use threads 2.09;' .
+run_perl(prog => 'use threads 2.12;' .
                  'threads->exit(86);' .
                  'exit(99);',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -98,7 +98,7 @@ $rc = $thr->join();
 ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
 
 
-run_perl(prog => 'use threads 2.09 qw(exit thread_only);' .
+run_perl(prog => 'use threads 2.12 qw(exit thread_only);' .
                  'threads->create(sub { exit(99); })->join();' .
                  'exit(86);',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -108,7 +108,7 @@ run_perl(prog => 'use threads 2.09 qw(exit thread_only);' .
     is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
 }
 
-my $out = run_perl(prog => 'use threads 2.09;' .
+my $out = run_perl(prog => 'use threads 2.12;' .
                            'threads->create(sub {' .
                            '    exit(99);' .
                            '});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 2.09;' .
 like($out, qr/1 finished and unjoined/, "exit(status) in thread");
 
 
-$out = run_perl(prog => 'use threads 2.09 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 2.12 qw(exit thread_only);' .
                         'threads->create(sub {' .
                         '   threads->set_thread_exit_only(0);' .
                         '   exit(99);' .
@@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 2.09 qw(exit thread_only);' .
 like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)");
 
 
-run_perl(prog => 'use threads 2.09;' .
+run_perl(prog => 'use threads 2.12;' .
                  'threads->create(sub {' .
                  '   $SIG{__WARN__} = sub { exit(99); };' .
                  '   die();' .

t/test.pl

@@ -652,7 +652,7 @@ sub _create_runperl { # Create the string to qx in runperl().
 	$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
     }
     unless ($args{nolib}) {
-	$runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
+	$runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS
     }
     if ($args{switches}) {
 	local $Level = 2;
@@ -953,11 +953,19 @@ sub register_tempfile {
     return $count;
 }
 
-# This is the temporary file for _fresh_perl
+# This is the temporary file for fresh_perl
 my $tmpfile = tempfile();
 
-sub _fresh_perl {
-    my($prog, $action, $expect, $runperl_args, $name) = @_;
+sub fresh_perl {
+    my($prog, $runperl_args) = @_;
+
+    # Run 'runperl' with the complete perl program contained in '$prog', and
+    # arguments in the hash referred to by '$runperl_args'.  The results are
+    # returned, with $? set to the exit code.  Unless overridden, stderr is
+    # redirected to stdout.
+
+    die sprintf "Third argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})"
+        unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH';
 
     # Given the choice of the mis-parsable {}
     # (we want an anon hash, but a borked lexer might think that it's a block)
@@ -970,12 +978,13 @@ sub _fresh_perl {
     $runperl_args->{progfile} ||= $tmpfile;
     $runperl_args->{stderr}     = 1 unless exists $runperl_args->{stderr};
 
-    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+    open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
     print TEST $prog;
     close TEST or die "Cannot close $tmpfile: $!";
 
     my $results = runperl(%$runperl_args);
-    my $status = $?;
+    my $status = $?;    # Not necessary to save this, but it makes it clear to
+                        # future maintainers.
 
     # Clean up the results into something a bit more predictable.
     $results  =~ s/\n+$//;
@@ -994,6 +1003,17 @@ sub _fresh_perl {
         $results =~ s/\n\n/\n/g;
     }
 
+    $? = $status;
+    return $results;
+}
+
+
+sub _fresh_perl {
+    my($prog, $action, $expect, $runperl_args, $name) = @_;
+
+    my $results = fresh_perl($prog, $runperl_args);
+    my $status = $?;
+
     # Use the first line of the program as a name if none was given
     unless( $name ) {
         ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
@@ -1058,8 +1078,9 @@ sub fresh_perl_like {
 # Each program is source code to run followed by an "EXPECT" line, followed
 # by the expected output.
 #
-# The code to run may begin with a command line switch such as -w or -0777
-# (alphanumerics only), and may contain (note the '# ' on each):
+# The first line of the code to run may be a command line switch such as -wE
+# or -0777 (alphanumerics only; only one cluster, beginning with a minus is
+# allowed).  Later lines may contain (note the '# ' on each):
 #   # TODO reason for todo
 #   # SKIP reason for skip
 #   # SKIP ?code to test if this should be skipped
@@ -1241,6 +1262,7 @@ sub run_multiple_progs {
 	open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!";
 	print $fh q{
         BEGIN {
+            push @INC, '.';
             open STDERR, '>&', STDOUT
               or die "Can't dup STDOUT->STDERR: $!;";
         }

t/thread.t

@@ -161,7 +161,7 @@ package main;
 
 # bugid #24165
 
-run_perl(prog => 'use threads 2.09;' .
+run_perl(prog => 'use threads 2.12;' .
                  'sub a{threads->create(shift)} $t = a sub{};' .
                  '$t->tid; $t->join; $t->tid',
          nolib => ($ENV{PERL_CORE}) ? 0 : 1,

threads.xs

@@ -1016,8 +1016,10 @@ S_ithread_create(
     MUTEX_UNLOCK(&my_pool->create_destruct_mutex);
     return (thread);
 
+#if defined(__clang__) || defined(__clang)
     CLANG_DIAG_IGNORE(-Wthread-safety);
     /* warning: mutex 'thread->mutex' is not held on every path through here [-Wthread-safety-analysis] */
+#endif
 }
 #if defined(__clang__) || defined(__clang)
 CLANG_DIAG_RESTORE;
@@ -1083,16 +1085,16 @@ ithread_create(...)
         if (specs) {
             SV **svp;
             /* stack_size */
-            if ((svp = hv_fetch(specs, "stack", 5, 0))) {
+            if ((svp = hv_fetchs(specs, "stack", 0))) {
                 stack_size = SvIV(*svp);
-            } else if ((svp = hv_fetch(specs, "stacksize", 9, 0))) {
+            } else if ((svp = hv_fetchs(specs, "stacksize", 0))) {
                 stack_size = SvIV(*svp);
-            } else if ((svp = hv_fetch(specs, "stack_size", 10, 0))) {
+            } else if ((svp = hv_fetchs(specs, "stack_size", 0))) {
                 stack_size = SvIV(*svp);
             }
 
             /* context */
-            if ((svp = hv_fetch(specs, "context", 7, 0))) {
+            if ((svp = hv_fetchs(specs, "context", 0))) {
                 str = (char *)SvPV_nolen(*svp);
                 switch (*str) {
                     case 'a':
@@ -1112,26 +1114,26 @@ ithread_create(...)
                     default:
                         Perl_croak(aTHX_ "Invalid context: %s", str);
                 }
-            } else if ((svp = hv_fetch(specs, "array", 5, 0))) {
+            } else if ((svp = hv_fetchs(specs, "array", 0))) {
                 if (SvTRUE(*svp)) {
                     context = G_ARRAY;
                 }
-            } else if ((svp = hv_fetch(specs, "list", 4, 0))) {
+            } else if ((svp = hv_fetchs(specs, "list", 0))) {
                 if (SvTRUE(*svp)) {
                     context = G_ARRAY;
                 }
-            } else if ((svp = hv_fetch(specs, "scalar", 6, 0))) {
+            } else if ((svp = hv_fetchs(specs, "scalar", 0))) {
                 if (SvTRUE(*svp)) {
                     context = G_SCALAR;
                 }
-            } else if ((svp = hv_fetch(specs, "void", 4, 0))) {
+            } else if ((svp = hv_fetchs(specs, "void", 0))) {
                 if (SvTRUE(*svp)) {
                     context = G_VOID;
                 }
             }
 
             /* exit => thread_only */
-            if ((svp = hv_fetch(specs, "exit", 4, 0))) {
+            if ((svp = hv_fetchs(specs, "exit", 0))) {
                 str = (char *)SvPV_nolen(*svp);
                 exit_opt = (*str == 't' || *str == 'T')
                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;