@@ -1,5 +1,10 @@
Revision history for Perl extension threads.
+1.75 Mon Nov 23 15:32:28 2009
+ - Conditionally compile tmps stack cleanup code (bug #70411)
+ - Support mingw64
+ - Install in 'site' for Perl >= 5.011
+
1.74 Mon Aug 10 18:53:59 2009
- Updated DESCRIPTION in POD
- Added 'no_threads' test
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: threads
-version: 1.74
+version: 1.75
abstract: Perl interpreter-based threads
author:
- Artur Bergman, Jerry D. Hedden <jdhedden AT cpan DOT org>
@@ -80,7 +80,7 @@ WriteMakefile(
'PM' => {
'threads.pm' => '$(INST_LIBDIR)/threads.pm',
},
- 'INSTALLDIRS' => 'perl',
+ 'INSTALLDIRS' => (($] < 5.011) ? 'perl' : 'site'),
((ExtUtils::MakeMaker->VERSION() lt '6.25') ?
('PL_FILES' => { }) : ()),
@@ -1,4 +1,4 @@
-threads version 1.74
+threads version 1.75
====================
This module exposes interpreter threads to the Perl level.
@@ -2,7 +2,7 @@ use strict;
use warnings;
BEGIN {
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
use Config;
if (! $Config{'useithreads'}) {
@@ -2,7 +2,7 @@ use strict;
use warnings;
BEGIN {
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
use Config;
if (! $Config{'useithreads'}) {
@@ -48,7 +48,7 @@ my $rc = $thr->join();
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.74;' .
+run_perl(prog => 'use threads 1.75;' .
'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 1.74 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.75 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 1.74 qw(exit thread_only);' .
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
}
-my $out = run_perl(prog => 'use threads 1.74;' .
+my $out = run_perl(prog => 'use threads 1.75;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.74;' .
like($out, '1 finished and unjoined', "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.74 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.75 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 1.74 qw(exit thread_only);' .
like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.74;' .
+run_perl(prog => 'use threads 1.75;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
@@ -5,7 +5,7 @@ BEGIN {
# Import test.pl into its own package
{
package Test;
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
}
use Config;
@@ -5,7 +5,7 @@ BEGIN {
# Import test.pl into its own package
{
package Test;
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
}
use Config;
@@ -2,7 +2,7 @@ use strict;
use warnings;
BEGIN {
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
use Config;
if (! $Config{'useithreads'}) {
@@ -99,7 +99,7 @@ sub _ok {
$out = $pass ? "ok $test" : "not ok $test";
}
- $out .= " # TODO $TODO" if $TODO;
+ $out = $out . " # TODO $TODO" if $TODO;
_print "$out\n";
unless ($pass) {
@@ -153,13 +153,22 @@ sub display {
my $y = '';
foreach my $c (unpack("U*", $x)) {
if ($c > 255) {
- $y .= sprintf "\\x{%x}", $c;
+ $y = $y . sprintf "\\x{%x}", $c;
} elsif ($backslash_escape{$c}) {
- $y .= $backslash_escape{$c};
+ $y = $y . $backslash_escape{$c};
} else {
my $z = chr $c; # Maybe we can get away with a literal...
- $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
- $y .= $z;
+ if ($z =~ /[[:^print:]]/) {
+
+ # Use octal for characters traditionally expressed as
+ # such: the low controls
+ if ($c <= 037) {
+ $z = sprintf "\\%03o", $c;
+ } else {
+ $z = sprintf "\\x{%x}", $c;
+ }
+ }
+ $y = $y . $z;
}
}
$x = $y;
@@ -183,8 +192,8 @@ sub is ($$@) {
}
unless ($pass) {
- unshift(@mess, "# got "._q($got)."\n",
- "# expected "._q($expected)."\n");
+ unshift(@mess, "# got "._qq($got)."\n",
+ "# expected "._qq($expected)."\n");
}
_ok($pass, _where(), $name, @mess);
}
@@ -202,7 +211,7 @@ sub isnt ($$@) {
}
unless( $pass ) {
- unshift(@mess, "# it should not be "._q($got)."\n",
+ unshift(@mess, "# it should not be "._qq($got)."\n",
"# but it is.\n");
}
_ok($pass, _where(), $name, @mess);
@@ -229,8 +238,8 @@ sub cmp_ok ($$$@) {
if ($got eq $expected and $type !~ tr/a-z//) {
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
}
- unshift(@mess, "# got "._q($got)."\n",
- "# expected $type "._q($expected)."\n");
+ unshift(@mess, "# got "._qq($got)."\n",
+ "# expected $type "._qq($expected)."\n");
}
_ok($pass, _where(), $name, @mess);
}
@@ -266,8 +275,8 @@ sub within ($$$@) {
if ($got eq $expected) {
unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
}
- unshift@mess, "# got "._q($got)."\n",
- "# expected "._q($expected)." (within "._q($range).")\n";
+ unshift@mess, "# got "._qq($got)."\n",
+ "# expected "._qq($expected)." (within "._qq($range).")\n";
}
_ok($pass, _where(), $name, @mess);
}
@@ -405,7 +414,6 @@ USE_OK
my $is_mswin = $^O eq 'MSWin32';
my $is_netware = $^O eq 'NetWare';
-my $is_macos = $^O eq 'MacOS';
my $is_vms = $^O eq 'VMS';
my $is_cygwin = $^O eq 'cygwin';
@@ -416,8 +424,9 @@ sub _quote_args {
# In VMS protect with doublequotes because otherwise
# DCL will lowercase -- unless already doublequoted.
$_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
- $$runperl .= ' ' . $_;
+ $runperl = $runperl . ' ' . $_;
}
+ return $runperl;
}
sub _create_runperl { # Create the string to qx in runperl().
@@ -431,20 +440,13 @@ sub _create_runperl { # Create the string to qx in runperl().
$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
}
unless ($args{nolib}) {
- if ($is_macos) {
- $runperl .= ' -I::lib';
- # Use UNIX style error messages instead of MPW style.
- $runperl .= ' -MMac::err=unix' if $args{stderr};
- }
- else {
- $runperl .= ' "-I../lib"'; # doublequotes because of VMS
- }
+ $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
}
if ($args{switches}) {
local $Level = 2;
die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where()
unless ref $args{switches} eq "ARRAY";
- _quote_args(\$runperl, $args{switches});
+ $runperl = _quote_args($runperl, $args{switches});
}
if (defined $args{prog}) {
die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
@@ -456,14 +458,14 @@ sub _create_runperl { # Create the string to qx in runperl().
unless ref $args{progs} eq "ARRAY";
foreach my $prog (@{$args{progs}}) {
if ($is_mswin || $is_netware || $is_vms) {
- $runperl .= qq ( -e "$prog" );
+ $runperl = $runperl . qq ( -e "$prog" );
}
else {
- $runperl .= qq ( -e '$prog' );
+ $runperl = $runperl . qq ( -e '$prog' );
}
}
} elsif (defined $args{progfile}) {
- $runperl .= qq( "$args{progfile}");
+ $runperl = $runperl . qq( "$args{progfile}");
} else {
# You probaby didn't want to be sucking in from the upstream stdin
die "test.pl:runperl(): none of prog, progs, progfile, args, "
@@ -481,29 +483,15 @@ sub _create_runperl { # Create the string to qx in runperl().
$runperl = qq{$Perl -e "print qq(} .
$args{stdin} . q{)" | } . $runperl;
}
- elsif ($is_macos) {
- # MacOS can only do two processes under MPW at once;
- # the test itself is one; we can't do two more, so
- # write to temp file
- my $stdin = qq{$Perl -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
- if ($args{verbose}) {
- my $stdindisplay = $stdin;
- $stdindisplay =~ s/\n/\n\#/g;
- _print_stderr "# $stdindisplay\n";
- }
- `$stdin`;
- $runperl .= q{ < teststdin };
- }
else {
$runperl = qq{$Perl -e 'print qq(} .
$args{stdin} . q{)' | } . $runperl;
}
}
if (defined $args{args}) {
- _quote_args(\$runperl, $args{args});
+ $runperl = _quote_args($runperl, $args{args});
}
- $runperl .= ' 2>&1' if $args{stderr} && !$is_macos;
- $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos;
+ $runperl = $runperl . ' 2>&1' if $args{stderr};
if ($args{verbose}) {
my $runperldisplay = $runperl;
$runperldisplay =~ s/\n/\n\#/g;
@@ -543,7 +531,7 @@ sub runperl {
join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
split quotemeta ($sep), $1;
- $ENV{PATH} .= "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin
+ $ENV{PATH} = $ENV{PATH} . "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin
$runperl =~ /(.*)/s;
$runperl = $1;
@@ -598,7 +586,7 @@ sub which_perl {
# the command.
if ($Perl !~ /\Q$exe\E$/i) {
- $Perl .= $exe;
+ $Perl = $Perl . $exe;
}
warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
@@ -630,14 +618,14 @@ sub tempfile {
my $temp = $count;
my $try = "tmp$$";
do {
- $try .= $letters[$temp % 26];
+ $try = $try . $letters[$temp % 26];
$temp = int ($temp / 26);
} while $temp;
# Need to note all the file names we allocated, as a second request may
# come before the first is created.
if (!-e $try && !$tmpfiles{$try}) {
# We have a winner
- $tmpfiles{$try}++;
+ $tmpfiles{$try} = 1;
return $try;
}
$count = $count + 1;
@@ -659,7 +647,14 @@ my $tmpfile = tempfile();
sub _fresh_perl {
my($prog, $resolve, $runperl_args, $name) = @_;
- $runperl_args ||= {};
+ # Given the choice of the mis-parsable {}
+ # (we want an anon hash, but a borked lexer might think that it's a block)
+ # or relying on taking a reference to a lexical
+ # (\ might be mis-parsed, and the reference counting on the pad may go
+ # awry)
+ # it feels like the least-worse thing is to assume that auto-vivification
+ # works. At least, this is only going to be a run-time failure, so won't
+ # affect tests using this file but not this function.
$runperl_args->{progfile} = $tmpfile;
$runperl_args->{stderr} = 1;
@@ -708,7 +703,7 @@ sub _fresh_perl {
# Use the first line of the program as a name if none was given
unless( $name ) {
($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
- $name .= '...' if length $first_line > length $name;
+ $name = $name . '...' if length $first_line > length $name;
}
_ok($pass, _where(), "fresh_perl - $name");
@@ -846,10 +841,10 @@ sub watchdog ($)
_diag("Watchdog warning: $_[0]");
};
my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL';
- $watchdog = system(1, which_perl(), '-e',
- "sleep($timeout);" .
- "warn('# $timeout_msg\n');" .
+ my $cmd = _create_runperl( prog => "sleep($timeout);" .
+ "warn qq/# $timeout_msg" . '\n/;' .
"kill($sig, $pid_to_kill);");
+ $watchdog = system(1, $cmd);
};
if ($@ || ($watchdog <= 0)) {
_diag('Failed to start watchdog');
@@ -913,7 +908,7 @@ sub watchdog ($)
# Execute the timeout
my $time_left = $timeout;
do {
- $time_left -= sleep($time_left);
+ $time_left = $time_left - sleep($time_left);
} while ($time_left > 0);
# Kill the parent (and ourself)
@@ -2,7 +2,7 @@ use strict;
use warnings;
BEGIN {
- require($ENV{PERL_CORE} ? './test.pl' : './t/test.pl');
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
use Config;
if (! $Config{'useithreads'}) {
@@ -161,7 +161,7 @@ package main;
# bugid #24165
-run_perl(prog => 'use threads 1.74;' .
+run_perl(prog => 'use threads 1.75;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -5,7 +5,7 @@ use 5.008;
use strict;
use warnings;
-our $VERSION = '1.74';
+our $VERSION = '1.75';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
=head1 VERSION
-This document describes threads version 1.74
+This document describes threads version 1.75
=head1 SYNOPSIS
@@ -1021,7 +1021,7 @@ L<threads> Discussion Forum on CPAN:
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.74/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.75/threads.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
@@ -1,11 +1,17 @@
#define PERL_NO_GET_CONTEXT
+/* Workaround for mingw 32-bit compiler by mingw-w64.sf.net - has to come before any #include.
+ * It also defines USE_NO_MINGW_SETJMP_TWO_ARGS for the mingw.org 32-bit compilers ... but
+ * that's ok as that compiler makes no use of that symbol anyway */
+#if defined(WIN32) && defined(__MINGW32__) && !defined(__MINGW64__)
+# define USE_NO_MINGW_SETJMP_TWO_ARGS 1
+#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
/* Workaround for XSUB.h bug under WIN32 */
#ifdef WIN32
# undef setjmp
-# if !defined(__BORLANDC__)
+# if defined(USE_NO_MINGW_SETJMP_TWO_ARGS) || (!defined(__BORLANDC__) && !defined(__MINGW64__))
# define setjmp(x) _setjmp(x)
# endif
#endif
@@ -674,8 +680,10 @@ S_ithread_create(
ithread *thread;
ithread *current_thread = S_ithread_get(aTHX);
+#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
SV **tmps_tmp = PL_tmps_stack;
IV tmps_ix = PL_tmps_ix;
+#endif
#ifndef WIN32
int rc_stack_size = 0;
int rc_thread_create = 0;
@@ -781,12 +789,13 @@ S_ithread_create(
sv_copypv(thread->init_function, init_function);
} else {
thread->init_function =
- SvREFCNT_inc(sv_dup(init_function, &clone_param));
+ SvREFCNT_inc(sv_dup(init_function, &clone_param));
}
thread->params = sv_dup(params, &clone_param);
SvREFCNT_inc_void(thread->params);
+#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
/* The code below checks that anything living on the tmps stack and
* has been cloned (so it lives in the ptr_table) has a refcount
* higher than 0.
@@ -799,7 +808,7 @@ S_ithread_create(
* Example of this can be found in bugreport 15837 where calls in the
* parameter list end up as a temp.
*
- * One could argue that this fix should be in perl_clone.
+ * As of 5.8.8 this is done in perl_clone.
*/
while (tmps_ix > 0) {
SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
@@ -809,6 +818,7 @@ S_ithread_create(
SvREFCNT_dec(sv);
}
}
+#endif
SvTEMP_off(thread->init_function);
ptr_table_free(PL_ptr_table);