Projects
Mega:23.09
perl-threads
_service:tar_scm:backport-threads-2.21-upgradet...
Sign Up
Log In
Username
Password
Overview
Repositories
Revisions
Requests
Users
Attributes
Meta
File _service:tar_scm:backport-threads-2.21-upgradeto-2.36.patch of Package perl-threads
From 938e1e6434e3912e98dc953f3e40dc7761992633 Mon Sep 17 00:00:00 2001 From: zhangyao <zhangyao108@huawei.com> Date: Thu, 25 Jan 2024 20:45:05 +0800 Subject: [PATCH] threads 2.21 upgrade to 2.36 Reference: Unbundled from perl 5.38.2 --- lib/threads.pm | 51 +- t/libc.t | 3 + t/pod.t | 87 --- t/stack.t | 82 ++- t/stack_env.t | 46 +- t/test.pl | 1749 ------------------------------------------------ t/thread.t | 4 +- t/version.t | 31 + threads.h | 31 - threads.xs | 87 ++- 10 files changed, 234 insertions(+), 1937 deletions(-) delete mode 100644 t/pod.t delete mode 100644 t/test.pl create mode 100644 t/version.t diff --git a/lib/threads.pm b/lib/threads.pm index 2eb926a..ecf025d 100644 --- a/lib/threads.pm +++ b/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '2.21'; # remember to update version in POD! +our $VERSION = '2.36'; # remember to update version in POD! my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,13 +134,13 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 2.21 +This document describes threads version 2.36 =head1 WARNING The "interpreter-based threads" provided by Perl are not the fast, lightweight system for multitasking that one might expect or hope for. Threads are -implemented in a way that make them easy to misuse. Few people know how to +implemented in a way that makes them easy to misuse. Few people know how to use them correctly or will be able to provide help. The use of interpreter-based threads in perl is officially @@ -914,7 +914,7 @@ C<-E<gt>import()>) after any threads are started, and in such a way that no other threads are started afterwards. If the above does not work, or is not adequate for your application, then file -a bug report on L<http://rt.cpan.org/Public/> against the problematic module. +a bug report on L<https://rt.cpan.org/Public/> against the problematic module. =item Memory consumption @@ -937,6 +937,33 @@ C<chdir()>) will affect all the threads in the application. On MSWin32, each thread maintains its own the current working directory setting. +=item Locales + +Prior to Perl 5.28, locales could not be used with threads, due to various +race conditions. Starting in that release, on systems that implement +thread-safe locale functions, threads can be used, with some caveats. +This includes Windows starting with Visual Studio 2005, and systems compatible +with POSIX 2008. See L<perllocale/Multi-threaded operation>. + +Each thread (except the main thread) is started using the C locale. The main +thread is started like all other Perl programs; see L<perllocale/ENVIRONMENT>. +You can switch locales in any thread as often as you like. + +If you want to inherit the parent thread's locale, you can, in the parent, set +a variable like so: + + $foo = POSIX::setlocale(LC_ALL, NULL); + +and then pass to threads->create() a sub that closes over C<$foo>. Then, in +the child, you say + + POSIX::setlocale(LC_ALL, $foo); + +Or you can use the facilities in L<threads::shared> to pass C<$foo>; +or if the environment hasn't changed, in the child, do + + POSIX::setlocale(LC_ALL, ""); + =item Environment variables Currently, on all platforms except MSWin32, all I<system> calls (e.g., using @@ -999,7 +1026,7 @@ signalling behavior is only in effect in the following situations: =over 4 -=item * Perl has been built with C<PERL_OLD_SIGNALS> (see C<perl -V>). +=item * Perl has been built with C<PERL_OLD_SIGNALS> (see S<C<perl -V>>). =item * The environment variable C<PERL_SIGNALS> is set to C<unsafe> (see L<perlrun/"PERL_SIGNALS">). @@ -1063,7 +1090,7 @@ determine whether your system supports it. In prior perl versions, spawning threads with open directory handles would crash the interpreter. -L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154> +L<[perl #75154]|https://rt.perl.org/rt3/Public/Bug/Display.html?id=75154> =item Detached threads and global destruction @@ -1091,8 +1118,8 @@ unreferenced scalars. However, such warnings are harmless, and may safely be ignored. You can search for L<threads> related bug reports at -L<http://rt.cpan.org/Public/>. If needed submit any new bugs, problems, -patches, etc. to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads> +L<https://rt.cpan.org/Public/>. If needed submit any new bugs, problems, +patches, etc. to: L<https://rt.cpan.org/Public/Dist/Display.html?Name=threads> =back @@ -1110,14 +1137,14 @@ L<https://github.com/Dual-Life/threads> L<threads::shared>, L<perlthrtut> -L<http://www.perl.com/pub/a/2002/06/11/threads.html> and -L<http://www.perl.com/pub/a/2002/09/04/threads.html> +L<https://www.perl.com/pub/a/2002/06/11/threads.html> and +L<https://www.perl.com/pub/a/2002/09/04/threads.html> Perl threads mailing list: -L<http://lists.perl.org/list/ithreads.html> +L<https://lists.perl.org/list/ithreads.html> Stack size discussion: -L<http://www.perlmonks.org/?node_id=532956> +L<https://www.perlmonks.org/?node_id=532956> Sample code in the I<examples> directory of this distribution on CPAN. diff --git a/t/libc.t b/t/libc.t index 4f6f6ed..592b8d3 100644 --- a/t/libc.t +++ b/t/libc.t @@ -9,6 +9,9 @@ BEGIN { skip_all(q/Perl not compiled with 'useithreads'/); } + # Guard against bugs that result in deadlock + watchdog(1 * 60); + plan(11); } diff --git a/t/pod.t b/t/pod.t deleted file mode 100644 index 390f7e2..0000000 --- a/t/pod.t +++ /dev/null @@ -1,87 +0,0 @@ -use strict; -use warnings; - -use Test::More; -if ($ENV{RUN_MAINTAINER_TESTS}) { - plan 'tests' => 3; -} else { - plan 'skip_all' => 'Module maintainer tests'; -} - -SKIP: { - if (! eval 'use Test::Pod 1.26; 1') { - skip('Test::Pod 1.26 required for testing POD', 1); - } - - pod_file_ok('lib/threads.pm'); -} - -SKIP: { - if (! eval 'use Test::Pod::Coverage 1.08; 1') { - skip('Test::Pod::Coverage 1.08 required for testing POD coverage', 1); - } - - pod_coverage_ok('threads', - { - 'trustme' => [ - qr/^new$/, - qr/^exit$/, - qr/^async$/, - qr/^\(/, - qr/^(all|running|joinable)$/, - ], - 'private' => [ - qr/^import$/, - qr/^DESTROY$/, - qr/^bootstrap$/, - ] - } - ); -} - -SKIP: { - if (! eval 'use Test::Spelling; 1') { - skip('Test::Spelling required for testing POD spelling', 1); - } - if (system('aspell help >/dev/null 2>&1')) { - skip(q/'aspell' required for testing POD spelling/, 1); - } - set_spell_cmd('aspell list --lang=en'); - add_stopwords(<DATA>); - pod_file_spelling_ok('lib/threads.pm', 'thread.pm spelling'); - unlink("/home/$ENV{'USER'}/en.prepl", "/home/$ENV{'USER'}/en.pws"); -} - -exit(0); - -__DATA__ - -API -async -cpan -MSWin32 -pthreads -SIGTERM -TID -Config.pm - -Hedden -Artur -Soderberg -crystalflame -brecon -netrus -Rocco -Caputo -netrus -vipul -Ved -Prakash -presicient - -okay -unjoinable -incrementing - -MetaCPAN -__END__ diff --git a/t/stack.t b/t/stack.t index cfd6cf7..0dcc947 100644 --- a/t/stack.t +++ b/t/stack.t @@ -9,6 +9,20 @@ BEGIN { } } +my $frame_size; +my $frames; +my $size; + +BEGIN { + # XXX Note that if the default stack size happens to be the same as these + # numbers, that test 2 would return success just out of happenstance. + # This possibility could be lessened by choosing $frames to be something + # less likely than a power of 2 + $frame_size = 4096; + $frames = 128; + $size = $frames * $frame_size; +} + use ExtUtils::testlib; sub ok { @@ -25,77 +39,101 @@ sub ok { return ($ok); } +sub is { + my ($id, $got, $expected, $name) = @_; + + my $ok = ok($id, $got == $expected, $name); + if (! $ok) { + print(" GOT: $got\n"); + print("EXPECTED: $expected\n"); + } + + return ($ok); +} + BEGIN { $| = 1; print("1..18\n"); ### Number of tests that will be run ### }; -use threads ('stack_size' => 128*4096); +use threads ('stack_size' => $size); ok(1, 1, 'Loaded'); ### Start of Testing ### -ok(2, threads->get_stack_size() == 128*4096, - 'Stack size set in import'); -ok(3, threads->set_stack_size(160*4096) == 128*4096, +my $actual_size = threads->get_stack_size(); + +{ + if ($actual_size > $size) { + print("ok 2 # skip because system needs larger minimum stack size\n"); + $size = $actual_size; + } + else { + is(2, $actual_size, $size, 'Stack size set in import'); + } +} + +my $size_plus_quarter = $size * 1.25; # 128 frames map to 160 +is(3, threads->set_stack_size($size_plus_quarter), $size, 'Set returns previous value'); -ok(4, threads->get_stack_size() == 160*4096, +is(4, threads->get_stack_size(), $size_plus_quarter, 'Get stack size'); threads->create( sub { - ok(5, threads->get_stack_size() == 160*4096, + is(5, threads->get_stack_size(), $size_plus_quarter, 'Get stack size in thread'); - ok(6, threads->self()->get_stack_size() == 160*4096, + is(6, threads->self()->get_stack_size(), $size_plus_quarter, 'Thread gets own stack size'); - ok(7, threads->set_stack_size(128*4096) == 160*4096, + is(7, threads->set_stack_size($size), $size_plus_quarter, 'Thread changes stack size'); - ok(8, threads->get_stack_size() == 128*4096, + is(8, threads->get_stack_size(), $size, 'Get stack size in thread'); - ok(9, threads->self()->get_stack_size() == 160*4096, + is(9, threads->self()->get_stack_size(), $size_plus_quarter, 'Thread stack size unchanged'); } )->join(); -ok(10, threads->get_stack_size() == 128*4096, +is(10, threads->get_stack_size(), $size, 'Default thread sized changed in thread'); threads->create( - { 'stack' => 160*4096 }, + { 'stack' => $size_plus_quarter }, sub { - ok(11, threads->get_stack_size() == 128*4096, + is(11, threads->get_stack_size(), $size, 'Get stack size in thread'); - ok(12, threads->self()->get_stack_size() == 160*4096, + is(12, threads->self()->get_stack_size(), $size_plus_quarter, 'Thread gets own stack size'); } )->join(); -my $thr = threads->create( { 'stack' => 160*4096 }, sub { } ); +my $thr = threads->create( { 'stack' => $size_plus_quarter }, sub { } ); $thr->create( sub { - ok(13, threads->get_stack_size() == 128*4096, + is(13, threads->get_stack_size(), $size, 'Get stack size in thread'); - ok(14, threads->self()->get_stack_size() == 160*4096, + is(14, threads->self()->get_stack_size(), $size_plus_quarter, 'Thread gets own stack size'); } )->join(); +my $size_plus_eighth = $size * 1.125; # 128 frames map to 144 $thr->create( - { 'stack' => 144*4096 }, + { 'stack' => $size_plus_eighth }, sub { - ok(15, threads->get_stack_size() == 128*4096, + is(15, threads->get_stack_size(), $size, 'Get stack size in thread'); - ok(16, threads->self()->get_stack_size() == 144*4096, + is(16, threads->self()->get_stack_size(), $size_plus_eighth, 'Thread gets own stack size'); - ok(17, threads->set_stack_size(160*4096) == 128*4096, + is(17, threads->set_stack_size($size_plus_quarter), $size, 'Thread changes stack size'); } )->join(); $thr->join(); -ok(18, threads->get_stack_size() == 160*4096, +is(18, threads->get_stack_size(), $size_plus_quarter, 'Default thread sized changed in thread'); exit(0); diff --git a/t/stack_env.t b/t/stack_env.t index e36812f..fdb38cc 100644 --- a/t/stack_env.t +++ b/t/stack_env.t @@ -25,11 +25,36 @@ sub ok { return ($ok); } +sub is { + my ($id, $got, $expected, $name) = @_; + + my $ok = ok($id, $got == $expected, $name); + if (! $ok) { + print(" GOT: $got\n"); + print("EXPECTED: $expected\n"); + } + + return ($ok); +} + +my $frame_size; +my $frames; +my $size; + BEGIN { $| = 1; print("1..4\n"); ### Number of tests that will be run ### - $ENV{'PERL5_ITHREADS_STACK_SIZE'} = 128*4096; + # XXX Note that if the default stack size happens to be the same as these + # numbers, that test 2 would return success just out of happenstance. + # This possibility could be lessened by choosing $frames to be something + # less likely than a power of 2 + + $frame_size = 4096; + $frames = 128; + $size = $frames * $frame_size; + + $ENV{'PERL5_ITHREADS_STACK_SIZE'} = $size; }; use threads; @@ -37,11 +62,22 @@ ok(1, 1, 'Loaded'); ### Start of Testing ### -ok(2, threads->get_stack_size() == 128*4096, - '$ENV{PERL5_ITHREADS_STACK_SIZE}'); -ok(3, threads->set_stack_size(144*4096) == 128*4096, +my $actual_size = threads->get_stack_size(); + +{ + if ($actual_size > $size) { + print("ok 2 # skip because system needs larger minimum stack size\n"); + $size = $actual_size; + } + else { + is(2, $actual_size, $size, '$ENV{PERL5_ITHREADS_STACK_SIZE}'); + } +} + +my $size_plus_eighth = $size * 1.125; # 128 frames map to 144 +is(3, threads->set_stack_size($size_plus_eighth), $size, 'Set returns previous value'); -ok(4, threads->get_stack_size() == 144*4096, +is(4, threads->get_stack_size(), $size_plus_eighth, 'Get stack size'); exit(0); diff --git a/t/test.pl b/t/test.pl deleted file mode 100644 index 868911c..0000000 --- a/t/test.pl +++ /dev/null @@ -1,1749 +0,0 @@ -# -# t/test.pl - most of Test::More functionality without the fuss - - -# NOTE: -# -# Do not rely on features found only in more modern Perls here, as some CPAN -# distributions copy this file and must operate on older Perls. Similarly, keep -# things, simple as this may be run under fairly broken circumstances. For -# example, increment ($x++) has a certain amount of cleverness for things like -# -# $x = 'zz'; -# $x++; # $x eq 'aaa'; -# -# This stands more chance of breaking than just a simple -# -# $x = $x + 1 -# -# In this file, we use the latter "Baby Perl" approach, and increment -# will be worked over by t/op/inc.t - -$Level = 1; -my $test = 1; -my $planned; -my $noplan; -my $Perl; # Safer version of $^X set by which_perl() - -# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC -$::IS_ASCII = ord 'A' == 65; -$::IS_EBCDIC = ord 'A' == 193; - -$TODO = 0; -$NO_ENDING = 0; -$Tests_Are_Passing = 1; - -# Use this instead of print to avoid interference while testing globals. -sub _print { - local($\, $", $,) = (undef, ' ', ''); - print STDOUT @_; -} - -sub _print_stderr { - local($\, $", $,) = (undef, ' ', ''); - print STDERR @_; -} - -sub plan { - my $n; - if (@_ == 1) { - $n = shift; - if ($n eq 'no_plan') { - undef $n; - $noplan = 1; - } - } else { - my %plan = @_; - $plan{skip_all} and skip_all($plan{skip_all}); - $n = $plan{tests}; - } - _print "1..$n\n" unless $noplan; - $planned = $n; -} - - -# Set the plan at the end. See Test::More::done_testing. -sub done_testing { - my $n = $test - 1; - $n = shift if @_; - - _print "1..$n\n"; - $planned = $n; -} - - -END { - my $ran = $test - 1; - if (!$NO_ENDING) { - if (defined $planned && $planned != $ran) { - _print_stderr - "# Looks like you planned $planned tests but ran $ran.\n"; - } elsif ($noplan) { - _print "1..$ran\n"; - } - } -} - -sub _diag { - return unless @_; - my @mess = _comment(@_); - $TODO ? _print(@mess) : _print_stderr(@mess); -} - -# Use this instead of "print STDERR" when outputting failure diagnostic -# messages -sub diag { - _diag(@_); -} - -# Use this instead of "print" when outputting informational messages -sub note { - return unless @_; - _print( _comment(@_) ); -} - -sub is_miniperl { - return !defined &DynaLoader::boot_DynaLoader; -} - -sub set_up_inc { - # Don’t clobber @INC under miniperl - @INC = () unless is_miniperl; - unshift @INC, @_; -} - -sub _comment { - return map { /^#/ ? "$_\n" : "# $_\n" } - map { split /\n/ } @_; -} - -sub _have_dynamic_extension { - my $extension = shift; - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return 1; - } - $extension =~ s!::!/!g; - return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); -} - -sub skip_all { - if (@_) { - _print "1..0 # Skip @_\n"; - } else { - _print "1..0\n"; - } - exit(0); -} - -sub skip_all_if_miniperl { - skip_all(@_) if is_miniperl(); -} - -sub skip_all_without_dynamic_extension { - my ($extension) = @_; - skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); - return if &_have_dynamic_extension; - skip_all("$extension was not built"); -} - -sub skip_all_without_perlio { - skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); -} - -sub skip_all_without_config { - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return; - } - foreach (@_) { - next if $Config::Config{$_}; - my $key = $_; # Need to copy, before trying to modify. - $key =~ s/^use//; - $key =~ s/^d_//; - skip_all("no $key"); - } -} - -sub skip_all_without_unicode_tables { # (but only under miniperl) - if (is_miniperl()) { - skip_all_if_miniperl("Unicode tables not built yet") - unless eval 'require "unicore/Heavy.pl"'; - } -} - -sub find_git_or_skip { - my ($source_dir, $reason); - if (-d '.git') { - $source_dir = '.'; - } elsif (-l 'MANIFEST' && -l 'AUTHORS') { - my $where = readlink 'MANIFEST'; - die "Can't readling MANIFEST: $!" unless defined $where; - die "Confusing symlink target for MANIFEST, '$where'" - unless $where =~ s!/MANIFEST\z!!; - if (-d "$where/.git") { - # Looks like we are in a symlink tree - if (exists $ENV{GIT_DIR}) { - diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); - } else { - note("Found source tree at $where, setting \$ENV{GIT_DIR}"); - $ENV{GIT_DIR} = "$where/.git"; - } - $source_dir = $where; - } - } elsif (exists $ENV{GIT_DIR}) { - my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; - my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; - chomp $out; - if($out eq $commit) { - $source_dir = '.' - } - } - if ($source_dir) { - my $version_string = `git --version`; - if (defined $version_string - && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { - return $source_dir if eval "v$1 ge v1.5.0"; - # If you have earlier than 1.5.0 and it works, change this test - $reason = "in git checkout, but git version '$1$2' too old"; - } else { - $reason = "in git checkout, but cannot run git"; - } - } else { - $reason = 'not being run from a git checkout'; - } - if ($ENV{'PERL_BUILD_PACKAGING'}) { - $reason = 'PERL_BUILD_PACKAGING is set'; - } - skip_all($reason) if $_[0] && $_[0] eq 'all'; - skip($reason, @_); -} - -sub BAIL_OUT { - my ($reason) = @_; - _print("Bail out! $reason\n"); - exit 255; -} - -sub _ok { - my ($pass, $where, $name, @mess) = @_; - # Do not try to microoptimize by factoring out the "not ". - # VMS will avenge. - my $out; - if ($name) { - # escape out '#' or it will interfere with '# skip' and such - $name =~ s/#/\\#/g; - $out = $pass ? "ok $test - $name" : "not ok $test - $name"; - } else { - $out = $pass ? "ok $test" : "not ok $test"; - } - - if ($TODO) { - $out = $out . " # TODO $TODO"; - } else { - $Tests_Are_Passing = 0 unless $pass; - } - - _print "$out\n"; - - if ($pass) { - note @mess; # Ensure that the message is properly escaped. - } - else { - my $msg = "# Failed test $test - "; - $msg.= "$name " if $name; - $msg .= "$where\n"; - _diag $msg; - _diag @mess; - } - - $test = $test + 1; # don't use ++ - - return $pass; -} - -sub _where { - my @caller = caller($Level); - return "at $caller[1] line $caller[2]"; -} - -# DON'T use this for matches. Use like() instead. -sub ok ($@) { - my ($pass, $name, @mess) = @_; - _ok($pass, _where(), $name, @mess); -} - -sub _q { - my $x = shift; - return 'undef' unless defined $x; - my $q = $x; - $q =~ s/\\/\\\\/g; - $q =~ s/'/\\'/g; - return "'$q'"; -} - -sub _qq { - my $x = shift; - return defined $x ? '"' . display ($x) . '"' : 'undef'; -}; - -# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file. -# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!"). -my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*"; -eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }' - if !defined &re::is_regexp; - -# keys are the codes \n etc map to, values are 2 char strings such as \n -my %backslash_escape; -foreach my $x (split //, 'nrtfa\\\'"') { - $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; -} -# A way to display scalars containing control characters and Unicode. -# Trying to avoid setting $_, or relying on local $_ to work. -sub display { - my @result; - foreach my $x (@_) { - if (defined $x and not ref $x) { - my $y = ''; - foreach my $c (unpack($chars_template, $x)) { - if ($c > 255) { - $y = $y . sprintf "\\x{%x}", $c; - } elsif ($backslash_escape{$c}) { - $y = $y . $backslash_escape{$c}; - } else { - my $z = chr $c; # Maybe we can get away with a literal... - - if ($z !~ /[^[:^print:][:^ascii:]]/) { - # The pattern above is equivalent (by de Morgan's - # laws) to: - # $z !~ /(?[ [:print:] & [:ascii:] ])/ - # or, $z is not an ascii printable character - - # Use octal for characters with small ordinals that - # are traditionally expressed as octal: the controls - # below space, which on EBCDIC are almost all the - # controls, but on ASCII don't include DEL nor the C1 - # controls. - if ($c < ord " ") { - $z = sprintf "\\%03o", $c; - } else { - $z = sprintf "\\x{%x}", $c; - } - } - $y = $y . $z; - } - } - $x = $y; - } - return $x unless wantarray; - push @result, $x; - } - return @result; -} - -sub is ($$@) { - my ($got, $expected, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $expected ) { - # undef only matches undef - $pass = !defined $got && !defined $expected; - } - else { - $pass = $got eq $expected; - } - - unless ($pass) { - unshift(@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)."\n"); - } - _ok($pass, _where(), $name, @mess); -} - -sub isnt ($$@) { - my ($got, $isnt, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $isnt ) { - # undef only matches undef - $pass = defined $got || defined $isnt; - } - else { - $pass = $got ne $isnt; - } - - unless( $pass ) { - unshift(@mess, "# it should not be "._qq($got)."\n", - "# but it is.\n"); - } - _ok($pass, _where(), $name, @mess); -} - -sub cmp_ok ($$$@) { - my($got, $type, $expected, $name, @mess) = @_; - - my $pass; - { - local $^W = 0; - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! - $pass = eval "\$got $type \$expected"; - } - unless ($pass) { - # It seems Irix long doubles can have 2147483648 and 2147483648 - # that stringify to the same thing but are actually numerically - # different. Display the numbers if $type isn't a string operator, - # and the numbers are stringwise the same. - # (all string operators have alphabetic names, so tr/a-z// is true) - # This will also show numbers for some unneeded cases, but will - # definitely be helpful for things such as == and <= that fail - if ($got eq $expected and $type !~ tr/a-z//) { - unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; - } - unshift(@mess, "# got "._qq($got)."\n", - "# expected $type "._qq($expected)."\n"); - } - _ok($pass, _where(), $name, @mess); -} - -# Check that $got is within $range of $expected -# if $range is 0, then check it's exact -# else if $expected is 0, then $range is an absolute value -# otherwise $range is a fractional error. -# Here $range must be numeric, >= 0 -# Non numeric ranges might be a useful future extension. (eg %) -sub within ($$$@) { - my ($got, $expected, $range, $name, @mess) = @_; - my $pass; - if (!defined $got or !defined $expected or !defined $range) { - # This is a fail, but doesn't need extra diagnostics - } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { - # This is a fail - unshift @mess, "# got, expected and range must be numeric\n"; - } elsif ($range < 0) { - # This is also a fail - unshift @mess, "# range must not be negative\n"; - } elsif ($range == 0) { - # Within 0 is == - $pass = $got == $expected; - } elsif ($expected == 0) { - # If expected is 0, treat range as absolute - $pass = ($got <= $range) && ($got >= - $range); - } else { - my $diff = $got - $expected; - $pass = abs ($diff / $expected) < $range; - } - unless ($pass) { - if ($got eq $expected) { - unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; - } - unshift@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)." (within "._qq($range).")\n"; - } - _ok($pass, _where(), $name, @mess); -} - -# Note: this isn't quite as fancy as Test::More::like(). - -sub like ($$@) { like_yn (0,@_) }; # 0 for - -sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- - -sub like_yn ($$$@) { - my ($flip, undef, $expected, $name, @mess) = @_; - - # We just accept like(..., qr/.../), not like(..., '...'), and - # definitely not like(..., '/.../') like - # Test::Builder::maybe_regex() does. - unless (re::is_regexp($expected)) { - die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; - } - - my $pass; - $pass = $_[1] =~ /$expected/ if !$flip; - $pass = $_[1] !~ /$expected/ if $flip; - my $display_got = $_[1]; - $display_got = display($display_got); - my $display_expected = $expected; - $display_expected = display($display_expected); - unless ($pass) { - unshift(@mess, "# got '$display_got'\n", - $flip - ? "# expected !~ /$display_expected/\n" - : "# expected /$display_expected/\n"); - } - local $Level = $Level + 1; - _ok($pass, _where(), $name, @mess); -} - -sub pass { - _ok(1, '', @_); -} - -sub fail { - _ok(0, _where(), @_); -} - -sub curr_test { - $test = shift if @_; - return $test; -} - -sub next_test { - my $retval = $test; - $test = $test + 1; # don't use ++ - $retval; -} - -# Note: can't pass multipart messages since we try to -# be compatible with Test::More::skip(). -sub skip { - my $why = shift; - my $n = @_ ? shift : 1; - my $bad_swap; - my $both_zero; - { - local $^W = 0; - $bad_swap = $why > 0 && $n == 0; - $both_zero = $why == 0 && $n == 0; - } - if ($bad_swap || $both_zero || @_) { - my $arg = "'$why', '$n'"; - if (@_) { - $arg .= join(", ", '', map { qq['$_'] } @_); - } - die qq[$0: expected skip(why, count), got skip($arg)\n]; - } - for (1..$n) { - _print "ok $test # skip $why\n"; - $test = $test + 1; - } - local $^W = 0; - last SKIP; -} - -sub skip_if_miniperl { - skip(@_) if is_miniperl(); -} - -sub skip_without_dynamic_extension { - my $extension = shift; - skip("no dynamic loading on miniperl, no extension $extension", @_) - if is_miniperl(); - return if &_have_dynamic_extension($extension); - skip("extension $extension was not built", @_); -} - -sub todo_skip { - my $why = shift; - my $n = @_ ? shift : 1; - - for (1..$n) { - _print "not ok $test # TODO & SKIP $why\n"; - $test = $test + 1; - } - local $^W = 0; - last TODO; -} - -sub eq_array { - my ($ra, $rb) = @_; - return 0 unless $#$ra == $#$rb; - for my $i (0..$#$ra) { - next if !defined $ra->[$i] && !defined $rb->[$i]; - return 0 if !defined $ra->[$i]; - return 0 if !defined $rb->[$i]; - return 0 unless $ra->[$i] eq $rb->[$i]; - } - return 1; -} - -sub eq_hash { - my ($orig, $suspect) = @_; - my $fail; - while (my ($key, $value) = each %$suspect) { - # Force a hash recompute if this perl's internals can cache the hash key. - $key = "" . $key; - if (exists $orig->{$key}) { - if ( - defined $orig->{$key} != defined $value - || (defined $value && $orig->{$key} ne $value) - ) { - _print "# key ", _qq($key), " was ", _qq($orig->{$key}), - " now ", _qq($value), "\n"; - $fail = 1; - } - } else { - _print "# key ", _qq($key), " is ", _qq($value), - ", not in original.\n"; - $fail = 1; - } - } - foreach (keys %$orig) { - # Force a hash recompute if this perl's internals can cache the hash key. - $_ = "" . $_; - next if (exists $suspect->{$_}); - _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; - $fail = 1; - } - !$fail; -} - -# We only provide a subset of the Test::More functionality. -sub require_ok ($) { - my ($require) = @_; - if ($require =~ tr/[A-Za-z0-9:.]//c) { - fail("Invalid character in \"$require\", passed to require_ok"); - } else { - eval <<REQUIRE_OK; -require $require; -REQUIRE_OK - is($@, '', _where(), "require $require"); - } -} - -sub use_ok ($) { - my ($use) = @_; - if ($use =~ tr/[A-Za-z0-9:.]//c) { - fail("Invalid character in \"$use\", passed to use"); - } else { - eval <<USE_OK; -use $use; -USE_OK - is($@, '', _where(), "use $use"); - } -} - -# runperl - Runs a separate perl interpreter and returns its output. -# Arguments : -# switches => [ command-line switches ] -# nolib => 1 # don't use -I../lib (included by default) -# non_portable => Don't warn if a one liner contains quotes -# prog => one-liner (avoid quotes) -# progs => [ multi-liner (avoid quotes) ] -# progfile => perl script -# stdin => string to feed the stdin (or undef to redirect from /dev/null) -# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect -# stderr to stdout -# args => [ command-line arguments to the perl program ] -# verbose => print the command line - -my $is_mswin = $^O eq 'MSWin32'; -my $is_netware = $^O eq 'NetWare'; -my $is_vms = $^O eq 'VMS'; -my $is_cygwin = $^O eq 'cygwin'; - -sub _quote_args { - my ($runperl, $args) = @_; - - foreach (@$args) { - # In VMS protect with doublequotes because otherwise - # DCL will lowercase -- unless already doublequoted. - $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; - $runperl = $runperl . ' ' . $_; - } - return $runperl; -} - -sub _create_runperl { # Create the string to qx in runperl(). - my %args = @_; - my $runperl = which_perl(); - if ($runperl =~ m/\s/) { - $runperl = qq{"$runperl"}; - } - #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind - if ($ENV{PERL_RUNPERL_DEBUG}) { - $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; - } - unless ($args{nolib}) { - $runperl = $runperl . ' "-I../lib" "-I." '; # 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"; - $runperl = _quote_args($runperl, $args{switches}); - } - if (defined $args{prog}) { - die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() - if defined $args{progs}; - $args{progs} = [split /\n/, $args{prog}, -1] - } - if (defined $args{progs}) { - die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() - unless ref $args{progs} eq "ARRAY"; - foreach my $prog (@{$args{progs}}) { - if (!$args{non_portable}) { - if ($prog =~ tr/'"//) { - warn "quotes in prog >>$prog<< are not portable"; - } - if ($prog =~ /^([<>|]|2>)/) { - warn "Initial $1 in prog >>$prog<< is not portable"; - } - if ($prog =~ /&\z/) { - warn "Trailing & in prog >>$prog<< is not portable"; - } - } - if ($is_mswin || $is_netware || $is_vms) { - $runperl = $runperl . qq ( -e "$prog" ); - } - else { - $runperl = $runperl . qq ( -e '$prog' ); - } - } - } elsif (defined $args{progfile}) { - $runperl = $runperl . qq( "$args{progfile}"); - } else { - # You probably didn't want to be sucking in from the upstream stdin - die "test.pl:runperl(): none of prog, progs, progfile, args, " - . " switches or stdin specified" - unless defined $args{args} or defined $args{switches} - or defined $args{stdin}; - } - if (defined $args{stdin}) { - # so we don't try to put literal newlines and crs onto the - # command line. - $args{stdin} =~ s/\n/\\n/g; - $args{stdin} =~ s/\r/\\r/g; - - if ($is_mswin || $is_netware || $is_vms) { - $runperl = qq{$Perl -e "print qq(} . - $args{stdin} . q{)" | } . $runperl; - } - else { - $runperl = qq{$Perl -e 'print qq(} . - $args{stdin} . q{)' | } . $runperl; - } - } elsif (exists $args{stdin}) { - # Using the pipe construction above can cause fun on systems which use - # ksh as /bin/sh, as ksh does pipes differently (with one less process) - # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' - # the sh process forks two children, which use exec to start the two - # perl processes. The parent shell process persists for the duration of - # the pipeline, and the second perl process starts with no children. - # With ksh (and zsh), the shell saves a process by forking a child for - # just the first perl process, and execing itself to start the second. - # This means that the second perl process starts with one child which - # it didn't create. This causes "fun" when if the tests assume that - # wait (or waitpid) will only return information about processes - # started within the test. - # They also cause fun on VMS, where the pipe implementation returns - # the exit code of the process at the front of the pipeline, not the - # end. This messes up any test using OPTION FATAL. - # Hence it's useful to have a way to make STDIN be at eof without - # needing a pipeline, so that the fork tests have a sane environment - # without these surprises. - - # /dev/null appears to be surprisingly portable. - $runperl = $runperl . ($is_mswin ? ' <nul' : ' </dev/null'); - } - if (defined $args{args}) { - $runperl = _quote_args($runperl, $args{args}); - } - if (exists $args{stderr} && $args{stderr} eq 'devnull') { - $runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null'); - } - elsif ($args{stderr}) { - $runperl = $runperl . ' 2>&1'; - } - if ($args{verbose}) { - my $runperldisplay = $runperl; - $runperldisplay =~ s/\n/\n\#/g; - _print_stderr "# $runperldisplay\n"; - } - return $runperl; -} - -# sub run_perl {} is alias to below -sub runperl { - die "test.pl:runperl() does not take a hashref" - if ref $_[0] and ref $_[0] eq 'HASH'; - my $runperl = &_create_runperl; - my $result; - - my $tainted = ${^TAINT}; - my %args = @_; - exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; - - if ($tainted) { - # We will assume that if you're running under -T, you really mean to - # run a fresh perl, so we'll brute force launder everything for you - my $sep; - - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $sep = ':'; - } else { - $sep = $Config::Config{path_sep}; - } - - my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); - local @ENV{@keys} = (); - # Untaint, plus take out . and empty string: - local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); - $ENV{PATH} =~ /(.*)/s; - local $ENV{PATH} = - join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and - ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } - split quotemeta ($sep), $1; - if ($is_cygwin) { # Must have /bin under Cygwin - if (length $ENV{PATH}) { - $ENV{PATH} = $ENV{PATH} . $sep; - } - $ENV{PATH} = $ENV{PATH} . '/bin'; - } - $runperl =~ /(.*)/s; - $runperl = $1; - - $result = `$runperl`; - } else { - $result = `$runperl`; - } - $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these - return $result; -} - -# Nice alias -*run_perl = *run_perl = \&runperl; # shut up "used only once" warning - -sub DIE { - _print_stderr "# @_\n"; - exit 1; -} - -# A somewhat safer version of the sometimes wrong $^X. -sub which_perl { - unless (defined $Perl) { - $Perl = $^X; - - # VMS should have 'perl' aliased properly - return $Perl if $is_vms; - - my $exe; - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $exe = ''; - } else { - $exe = $Config::Config{_exe}; - } - $exe = '' unless defined $exe; - - # This doesn't absolutize the path: beware of future chdirs(). - # We could do File::Spec->abs2rel() but that does getcwd()s, - # which is a bit heavyweight to do here. - - if ($Perl =~ /^perl\Q$exe\E$/i) { - my $perl = "perl$exe"; - if (! eval {require File::Spec; 1}) { - warn "test.pl had problems loading File::Spec: $@"; - $Perl = "./$perl"; - } else { - $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); - } - } - - # Build up the name of the executable file from the name of - # the command. - - if ($Perl !~ /\Q$exe\E$/i) { - $Perl = $Perl . $exe; - } - - warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; - - # For subcommands to use. - $ENV{PERLEXE} = $Perl; - } - return $Perl; -} - -sub unlink_all { - my $count = 0; - foreach my $file (@_) { - 1 while unlink $file; - if( -f $file ){ - _print_stderr "# Couldn't unlink '$file': $!\n"; - }else{ - $count = $count + 1; # don't use ++ - } - } - $count; -} - -# _num_to_alpha - Returns a string of letters representing a positive integer. -# Arguments : -# number to convert -# maximum number of letters - -# returns undef if the number is negative -# returns undef if the number of letters is greater than the maximum wanted - -# _num_to_alpha( 0) eq 'A'; -# _num_to_alpha( 1) eq 'B'; -# _num_to_alpha(25) eq 'Z'; -# _num_to_alpha(26) eq 'AA'; -# _num_to_alpha(27) eq 'AB'; - -my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); - -# Avoid ++ -- ranges split negative numbers -sub _num_to_alpha{ - my($num,$max_char) = @_; - return unless $num >= 0; - my $alpha = ''; - my $char_count = 0; - $max_char = 0 if $max_char < 0; - - while( 1 ){ - $alpha = $letters[ $num % 26 ] . $alpha; - $num = int( $num / 26 ); - last if $num == 0; - $num = $num - 1; - - # char limit - next unless $max_char; - $char_count = $char_count + 1; - return if $char_count == $max_char; - } - return $alpha; -} - -my %tmpfiles; -END { unlink_all keys %tmpfiles } - -# A regexp that matches the tempfile names -$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; - -# Avoid ++, avoid ranges, avoid split // -my $tempfile_count = 0; -sub tempfile { - while(1){ - my $try = (-d "t" ? "t/" : "")."tmp$$"; - my $alpha = _num_to_alpha($tempfile_count,2); - last unless defined $alpha; - $try = $try . $alpha; - $tempfile_count = $tempfile_count + 1; - - # Need to note all the file names we allocated, as a second request may - # come before the first is created. - if (!$tmpfiles{$try} && !-e $try) { - # We have a winner - $tmpfiles{$try} = 1; - return $try; - } - } - die "Can't find temporary file name starting \"tmp$$\""; -} - -# register_tempfile - Adds a list of files to be removed at the end of the current test file -# Arguments : -# a list of files to be removed later - -# returns a count of how many file names were actually added - -# Reuses %tmpfiles so that tempfile() will also skip any files added here -# even if the file doesn't exist yet. - -sub register_tempfile { - my $count = 0; - for( @_ ){ - if( $tmpfiles{$_} ){ - _print_stderr "# Temporary file '$_' already added\n"; - }else{ - $tmpfiles{$_} = 1; - $count = $count + 1; - } - } - return $count; -} - -# This is the temporary file for fresh_perl -my $tmpfile = tempfile(); - -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) - # 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 unless exists $runperl_args->{stderr}; - - open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!"; - binmode TEST, ':utf8' if $runperl_args->{wide_chars}; - print TEST $prog; - close TEST or die "Cannot close $tmpfile: $!"; - - my $results = runperl(%$runperl_args); - 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+$//; - $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; - $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; - - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - - if ($is_vms) { - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $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}).*)/; - $name = $name . '...' if length $first_line > length $name; - } - - # Historically this was implemented using a closure, but then that means - # that the tests for closures avoid using this code. Given that there - # are exactly two callers, doing exactly two things, the simpler approach - # feels like a better trade off. - my $pass; - if ($action eq 'eq') { - $pass = is($results, $expect, $name); - } elsif ($action eq '=~') { - $pass = like($results, $expect, $name); - } else { - die "_fresh_perl can't process action '$action'"; - } - - unless ($pass) { - _diag "# PROG: \n$prog\n"; - _diag "# STATUS: $status\n"; - } - - return $pass; -} - -# -# fresh_perl_is -# -# Combination of run_perl() and is(). -# - -sub fresh_perl_is { - my($prog, $expected, $runperl_args, $name) = @_; - - # _fresh_perl() is going to clip the trailing newlines off the result. - # This will make it so the test author doesn't have to know that. - $expected =~ s/\n+$//; - - local $Level = 2; - _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); -} - -# -# fresh_perl_like -# -# Combination of run_perl() and like(). -# - -sub fresh_perl_like { - my($prog, $expected, $runperl_args, $name) = @_; - local $Level = 2; - _fresh_perl($prog, '=~', $expected, $runperl_args, $name); -} - -# Many tests use the same format in __DATA__ or external files to specify a -# sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. Putting it here allows common code to serve -# these multiple tests. -# -# Each program is source code to run followed by an "EXPECT" line, followed -# by the expected output. -# -# 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 -# # NAME name of the test (as with ok($ok, $name)) -# -# The expected output may contain: -# OPTION list of options -# OPTIONS list of options -# -# The possible options for OPTION may be: -# regex - the expected output is a regular expression -# random - all lines match but in any order -# fatal - the code will fail fatally (croak, die) -# -# If the actual output contains a line "SKIPPED" the test will be -# skipped. -# -# If the actual output contains a line "PREFIX", any output starting with that -# line will be ignored when comparing with the expected output -# -# If the global variable $FATAL is true then OPTION fatal is the -# default. - -sub _setup_one_file { - my $fh = shift; - # Store the filename as a program that started at line 0. - # Real files count lines starting at line 1. - my @these = (0, shift); - my ($lineno, $current); - while (<$fh>) { - if ($_ eq "########\n") { - if (defined $current) { - push @these, $lineno, $current; - } - undef $current; - } else { - if (!defined $current) { - $lineno = $.; - } - $current .= $_; - } - } - if (defined $current) { - push @these, $lineno, $current; - } - ((scalar @these) / 2 - 1, @these); -} - -sub setup_multiple_progs { - my ($tests, @prgs); - foreach my $file (@_) { - next if $file =~ /(?:~|\.orig|,v)$/; - next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); - next if -d $file; - - open my $fh, '<', $file or die "Cannot open $file: $!\n" ; - my $found; - while (<$fh>) { - if (/^__END__/) { - $found = $found + 1; # don't use ++ - last; - } - } - # This is an internal error, and should never happen. All bar one of - # the files had an __END__ marker to signal the end of their preamble, - # although for some it wasn't technically necessary as they have no - # tests. It might be possible to process files without an __END__ by - # seeking back to the start and treating the whole file as tests, but - # it's simpler and more reliable just to make the rule that all files - # must have __END__ in. This should never fail - a file without an - # __END__ should not have been checked in, because the regression tests - # would not have passed. - die "Could not find '__END__' in $file" - unless $found; - - my ($t, @p) = _setup_one_file($fh, $file); - $tests += $t; - push @prgs, @p; - - close $fh - or die "Cannot close $file: $!\n"; - } - return ($tests, @prgs); -} - -sub run_multiple_progs { - my $up = shift; - my @prgs; - if ($up) { - # The tests in lib run in a temporary subdirectory of t, and always - # pass in a list of "programs" to run - @prgs = @_; - } else { - # The tests below t run in t and pass in a file handle. In theory we - # can pass (caller)[1] as the second argument to report errors with - # the filename of our caller, as the handle is always DATA. However, - # line numbers in DATA count from the __END__ token, so will be wrong. - # Which is more confusing than not providing line numbers. So, for now, - # don't provide line numbers. No obvious clean solution - one hack - # would be to seek DATA back to the start and read to the __END__ token, - # but that feels almost like we should just open $0 instead. - - # Not going to rely on undef in list assignment. - my $dummy; - ($dummy, @prgs) = _setup_one_file(shift); - } - - my $tmpfile = tempfile(); - - my ($file, $line); - PROGRAM: - while (defined ($line = shift @prgs)) { - $_ = shift @prgs; - unless ($line) { - $file = $_; - if (defined $file) { - print "# From $file\n"; - } - next; - } - my $switch = ""; - my @temps ; - my @temp_path; - if (s/^(\s*-\w+)//) { - $switch = $1; - } - my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); - - my %reason; - foreach my $what (qw(skip todo)) { - $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; - # If the SKIP reason starts ? then it's taken as a code snippet to - # evaluate. This provides the flexibility to have conditional SKIPs - if ($reason{$what} && $reason{$what} =~ s/^\?//) { - my $temp = eval $reason{$what}; - if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; - } - $reason{$what} = $temp; - } - } - - my $name = ''; - if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { - $name = $1; - } - - if ($reason{skip}) { - SKIP: - { - skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); - } - next PROGRAM; - } - - if ($prog =~ /--FILE--/) { - my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error: test $_ didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2; - while (@files > 2) { - my $filename = shift @files; - my $code = shift @files; - push @temps, $filename; - if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { - require File::Path; - File::Path::mkpath($1); - push(@temp_path, $1); - } - open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; - print $fh $code; - close $fh or die "Cannot close $filename: $!\n"; - } - shift @files; - $prog = shift @files; - } - - 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: $!;"; - } - }; - print $fh "\n#line 1\n"; # So the line numbers don't get messed up. - print $fh $prog,"\n"; - close $fh or die "Cannot close $tmpfile: $!"; - my $results = runperl( stderr => 1, progfile => $tmpfile, - stdin => undef, $up - ? (switches => ["-I$up/lib", $switch], nolib => 1) - : (switches => [$switch]) - ); - my $status = $?; - $results =~ s/\n+$//; - # allow expected output to be written as if $prog is on STDIN - $results =~ s/$::tempfile_regexp/-/g; - if ($^O eq 'VMS') { - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - - $expected =~ s/\n+$//; - my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - my $option_random = 0; - my $fatal = $FATAL; - if ($expected =~ s/^OPTIONS? (.+)\n//) { - foreach my $option (split(' ', $1)) { - if ($option eq 'regex') { # allow regular expressions - $option_regex = 1; - } - elsif ($option eq 'random') { # all lines match, but in any order - $option_random = 1; - } - elsif ($option eq 'fatal') { # perl should fail - $fatal = 1; - } - else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - die "$0: can't have OPTION regex and random\n" - if $option_regex + $option_random > 1; - my $ok = 0; - if ($results =~ s/^SKIPPED\n//) { - print "$results\n" ; - $ok = 1; - } - else { - if ($option_random) { - my @got = sort split "\n", $results; - my @expected = sort split "\n", $expected; - - $ok = "@got" eq "@expected"; - } - elsif ($option_regex) { - $ok = $results =~ /^$expected/; - } - elsif ($prefix) { - $ok = $results =~ /^\Q$expected/; - } - else { - $ok = $results eq $expected; - } - - if ($ok && $fatal && !($status >> 8)) { - $ok = 0; - } - } - - local $::TODO = $reason{todo}; - - unless ($ok) { - my $err_line = "PROG: $switch\n$prog\n" . - "EXPECTED:\n$expected\n"; - $err_line .= "EXIT STATUS: != 0\n" if $fatal; - $err_line .= "GOT:\n$results\n"; - $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; - if ($::TODO) { - $err_line =~ s/^/# /mg; - print $err_line; # Harness can't filter it out from STDERR. - } - else { - print STDERR $err_line; - } - } - - if (defined $file) { - _ok($ok, "at $file line $line", $name); - } else { - # We don't have file and line number data for the test, so report - # errors as coming from our caller. - local $Level = $Level + 1; - ok($ok, $name); - } - - foreach (@temps) { - unlink $_ if $_; - } - foreach (@temp_path) { - File::Path::rmtree $_ if -d $_; - } - } -} - -sub can_ok ($@) { - my($proto, @methods) = @_; - my $class = ref $proto || $proto; - - unless( @methods ) { - return _ok( 0, _where(), "$class->can(...)" ); - } - - my @nok = (); - foreach my $method (@methods) { - local($!, $@); # don't interfere with caller's $@ - # eval sometimes resets $! - eval { $proto->can($method) } || push @nok, $method; - } - - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; - - _ok( !@nok, _where(), $name ); -} - - -# Call $class->new( @$args ); and run the result through object_ok. -# See Test::More::new_ok -sub new_ok { - my($class, $args, $obj_name) = @_; - $args ||= []; - $object_name = "The object" unless defined $obj_name; - - local $Level = $Level + 1; - - my $obj; - my $ok = eval { $obj = $class->new(@$args); 1 }; - my $error = $@; - - if($ok) { - object_ok($obj, $class, $object_name); - } - else { - ok( 0, "new() died" ); - diag("Error was: $@"); - } - - return $obj; - -} - - -sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; - - my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; - if( !defined $object ) { - $diag = "$obj_name isn't defined"; - } - else { - my $whatami = ref $object ? 'object' : 'class'; - - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - local($@, $!); # eval sometimes resets $! - my $rslt = eval { $object->isa($class) }; - my $error = $@; # in case something else blows away $@ - - if( $error ) { - if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { - # It's an unblessed reference - $obj_name = 'The reference' unless defined $obj_name; - if( !UNIVERSAL::isa($object, $class) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - elsif( $error =~ /Can't call method "isa" without a package/ ) { - # It's something that can't even be a class - $obj_name = 'The thing' unless defined $obj_name; - $diag = "$obj_name isn't a class or reference"; - } - else { - die <<WHOA; -WHOA! I tried to call ->isa on your object and got some weird error. -This should never happen. Please contact the author immediately. -Here's the error. -$@ -WHOA - } - } - elsif( !$rslt ) { - $obj_name = "The $whatami" unless defined $obj_name; - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - - _ok( !$diag, _where(), $name ); -} - - -sub class_ok { - my($class, $isa, $class_name) = @_; - - # Written so as to count as one test - local $Level = $Level + 1; - if( ref $class ) { - ok( 0, "$class is a reference, not a class name" ); - } - else { - isa_ok($class, $isa, $class_name); - } -} - - -sub object_ok { - my($obj, $isa, $obj_name) = @_; - - local $Level = $Level + 1; - if( !ref $obj ) { - ok( 0, "$obj is not a reference" ); - } - else { - isa_ok($obj, $isa, $obj_name); - } -} - - -# Purposefully avoiding a closure. -sub __capture { - push @::__capture, join "", @_; -} - -sub capture_warnings { - my $code = shift; - - local @::__capture; - local $SIG {__WARN__} = \&__capture; - local $Level = 1; - &$code; - return @::__capture; -} - -# This will generate a variable number of tests. -# Use done_testing() instead of a fixed plan. -sub warnings_like { - my ($code, $expect, $name) = @_; - local $Level = $Level + 1; - - my @w = capture_warnings($code); - - cmp_ok(scalar @w, '==', scalar @$expect, $name); - foreach my $e (@$expect) { - if (ref $e) { - like(shift @w, $e, $name); - } else { - is(shift @w, $e, $name); - } - } - if (@w) { - diag("Saw these additional warnings:"); - diag($_) foreach @w; - } -} - -sub _fail_excess_warnings { - my($expect, $got, $name) = @_; - local $Level = $Level + 1; - # This will fail, and produce diagnostics - is($expect, scalar @$got, $name); - diag("Saw these warnings:"); - diag($_) foreach @$got; -} - -sub warning_is { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a string or undef, not a %s reference", ref $expect - if ref $expect; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - is($w[0], $expect, $name); - } -} - -sub warning_like { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a regexp object" - unless ref $expect eq 'Regexp'; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - like($w[0], $expect, $name); - } -} - -# Set a watchdog to timeout the entire test file -# NOTE: If the test file uses 'threads', then call the watchdog() function -# _AFTER_ the 'threads' module is loaded. -sub watchdog ($;$) -{ - my $timeout = shift; - my $method = shift || ""; - my $timeout_msg = 'Test process timed out - terminating'; - - # Valgrind slows perl way down so give it more time before dying. - $timeout *= 10 if $ENV{PERL_VALGRIND}; - - my $pid_to_kill = $$; # PID for this process - - if ($method eq "alarm") { - goto WATCHDOG_VIA_ALARM; - } - - # shut up use only once warning - my $threads_on = $threads::threads && $threads::threads; - - # Don't use a watchdog process if 'threads' is loaded - - # use a watchdog thread instead - if (!$threads_on || $method eq "process") { - - # On Windows and VMS, try launching a watchdog process - # using system(1, ...) (see perlport.pod) - if ($is_mswin || $is_vms) { - # On Windows, try to get the 'real' PID - if ($is_mswin) { - eval { require Win32; }; - if (defined(&Win32::GetCurrentProcessId)) { - $pid_to_kill = Win32::GetCurrentProcessId(); - } - } - - # If we still have a fake PID, we can't use this method at all - return if ($pid_to_kill <= 0); - - # Launch watchdog process - my $watchdog; - eval { - local $SIG{'__WARN__'} = sub { - _diag("Watchdog warning: $_[0]"); - }; - my $sig = $is_vms ? 'TERM' : 'KILL'; - my $prog = "sleep($timeout);" . - "warn qq/# $timeout_msg" . '\n/;' . - "kill(q/$sig/, $pid_to_kill);"; - - # On Windows use the indirect object plus LIST form to guarantee - # that perl is launched directly rather than via the shell (see - # perlfunc.pod), and ensure that the LIST has multiple elements - # since the indirect object plus COMMANDSTRING form seems to - # hang (see perl #121283). Don't do this on VMS, which doesn't - # support the LIST form at all. - if ($is_mswin) { - my $runperl = which_perl(); - if ($runperl =~ m/\s/) { - $runperl = qq{"$runperl"}; - } - $watchdog = system({ $runperl } 1, $runperl, '-e', $prog); - } - else { - my $cmd = _create_runperl(prog => $prog); - $watchdog = system(1, $cmd); - } - }; - if ($@ || ($watchdog <= 0)) { - _diag('Failed to start watchdog'); - _diag($@) if $@; - undef($watchdog); - return; - } - - # Add END block to parent to terminate and - # clean up watchdog process - eval("END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"); - return; - } - - # Try using fork() to generate a watchdog process - my $watchdog; - eval { $watchdog = fork() }; - if (defined($watchdog)) { - if ($watchdog) { # Parent process - # Add END block to parent to terminate and - # clean up watchdog process - eval "END { local \$! = 0; local \$? = 0; - wait() if kill('KILL', $watchdog); };"; - return; - } - - ### Watchdog process code - - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 - sleep(2); - - # Kill test process if still running - if (kill(0, $pid_to_kill)) { - _diag($timeout_msg); - kill('KILL', $pid_to_kill); - if ($is_cygwin) { - # sometimes the above isn't enough on cygwin - sleep 1; # wait a little, it might have worked after all - system("/bin/kill -f $pid_to_kill"); - } - } - - # Don't execute END block (added at beginning of this file) - $NO_ENDING = 1; - - # Terminate ourself (i.e., the watchdog) - POSIX::_exit(1) if (defined(&POSIX::_exit)); - exit(1); - } - - # fork() failed - fall through and try using a thread - } - - # Use a watchdog thread because either 'threads' is loaded, - # or fork() failed - if (eval {require threads; 1}) { - 'threads'->create(sub { - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - my $time_left = $timeout; - do { - $time_left = $time_left - sleep($time_left); - } while ($time_left > 0); - - # Kill the parent (and ourself) - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - })->detach(); - return; - } - - # If everything above fails, then just use an alarm timeout -WATCHDOG_VIA_ALARM: - if (eval { alarm($timeout); 1; }) { - # Load POSIX if available - eval { require POSIX; }; - - # Alarm handler will do the actual 'killing' - $SIG{'ALRM'} = sub { - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - }; - } -} - -1; diff --git a/t/thread.t b/t/thread.t index 4dc1a29..8a56bb6 100644 --- a/t/thread.t +++ b/t/thread.t @@ -11,6 +11,7 @@ BEGIN { } use ExtUtils::testlib; +use Data::Dumper; use threads; @@ -156,7 +157,8 @@ package main; rand(10); threads->create( sub { $rand{int(rand(10000000000))}++ } ) foreach 1..25; $_->join foreach threads->list; - ok((keys %rand >= 23), "Check that rand() is randomized in new threads"); + ok((keys %rand >= 23), "Check that rand() is randomized in new threads") + or diag Dumper(\%rand); } # bugid #24165 diff --git a/t/version.t b/t/version.t new file mode 100644 index 0000000..fb91309 --- /dev/null +++ b/t/version.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + use Config; + if (! $Config{'useithreads'}) { + print("1..0 # SKIP Perl not compiled with 'useithreads'\n"); + exit(0); + } +} + +use threads; + +# test that the version documented in threads.pm pod matches +# that of the code. + +open my $fh, "<", $INC{"threads.pm"} + or die qq(Failed to open '$INC{"threads.pm"}': $!); +my $file= do { local $/; <$fh> }; +close $fh; +my $pod_version = 0; +if ($file=~/This document describes threads version (\d.\d+)/) { + $pod_version = $1; +} +is($pod_version, $threads::VERSION, + "Check that pod and \$threads::VERSION match"); +done_testing(); + + + diff --git a/threads.h b/threads.h index bdfab49..e69de29 100644 --- a/threads.h +++ b/threads.h @@ -1,31 +0,0 @@ -#ifndef _THREADS_H_ -#define _THREADS_H_ - -/* Needed for 5.8.0 */ -#ifndef CLONEf_JOIN_IN -# define CLONEf_JOIN_IN 8 -#endif -#ifndef SAVEBOOL -# define SAVEBOOL(a) -#endif - -/* Added in 5.11.x */ -#ifndef G_WANT -# define G_WANT (128|1) -#endif - -/* Added in 5.24.x */ -#ifndef PERL_TSA_RELEASE -# define PERL_TSA_RELEASE(x) -#endif -#ifndef PERL_TSA_EXCLUDES -# define PERL_TSA_EXCLUDES(x) -#endif -#ifndef CLANG_DIAG_IGNORE -# define CLANG_DIAG_IGNORE(x) -#endif -#ifndef CLANG_DIAG_RESTORE -# define CLANG_DIAG_RESTORE -#endif - -#endif diff --git a/threads.xs b/threads.xs index 4e9e31f..25fec16 100644 --- a/threads.xs +++ b/threads.xs @@ -15,18 +15,20 @@ # define setjmp(x) _setjmp(x) # endif # if defined(__MINGW64__) +# include <intrin.h> # define setjmp(x) _setjmpex((x), mingw_getsp()) # endif #endif -#ifdef HAS_PPPORT_H -# define NEED_PL_signals -# define NEED_sv_2pv_flags -# include "ppport.h" -# include "threads.h" -#endif +#define NEED_PL_signals +#define NEED_sv_2pv_flags +#include "ppport.h" +#include "threads.h" #ifndef sv_dup_inc # define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #endif +#ifndef SvREFCNT_dec_NN +# define SvREFCNT_dec_NN(x) SvREFCNT_dec(x) +#endif #ifndef PERL_UNUSED_RESULT # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END @@ -91,8 +93,8 @@ typedef perl_os_thread pthread_t; typedef struct _ithread { struct _ithread *next; /* Next thread in the list */ struct _ithread *prev; /* Prev thread in the list */ - PerlInterpreter *interp; /* The threads interpreter */ - UV tid; /* Threads module's thread id */ + PerlInterpreter *interp; /* The thread's interpreter */ + UV tid; /* Thread's module's thread id */ perl_mutex mutex; /* Mutex for updating things in this struct */ int count; /* Reference count. See S_ithread_create. */ int state; /* Detached, joined, finished, etc. */ @@ -203,6 +205,9 @@ S_ithread_set(pTHX_ ithread *thread) { dMY_CXT; MY_CXT.context = thread; +#ifdef PERL_SET_NON_tTHX_CONTEXT + PERL_SET_NON_tTHX_CONTEXT(thread->interp); +#endif } STATIC ithread * @@ -241,18 +246,31 @@ S_ithread_clear(pTHX_ ithread *thread) S_block_most_signals(&origmask); #endif +#if PERL_VERSION_GE(5, 37, 5) + int save_veto = PL_veto_switch_non_tTHX_context; +#endif + interp = thread->interp; if (interp) { dTHXa(interp); + /* We will pretend to be a thread that we are not by switching tTHX, + * which doesn't work with things that don't rely on tTHX during + * tear-down, as they will tend to rely on a mapping from the tTHX + * structure, and that structure is being destroyed. */ +#if PERL_VERSION_GE(5, 37, 5) + PL_veto_switch_non_tTHX_context = true; +#endif + PERL_SET_CONTEXT(interp); + S_ithread_set(aTHX_ thread); SvREFCNT_dec(thread->params); thread->params = NULL; if (thread->err) { - SvREFCNT_dec(thread->err); + SvREFCNT_dec_NN(thread->err); thread->err = Nullsv; } @@ -262,6 +280,10 @@ S_ithread_clear(pTHX_ ithread *thread) } PERL_SET_CONTEXT(aTHX); +#if PERL_VERSION_GE(5, 37, 5) + PL_veto_switch_non_tTHX_context = save_veto; +#endif + #ifdef THREAD_SIGNAL_BLOCKING S_set_sigmask(&origmask); #endif @@ -421,7 +443,7 @@ STATIC const MGVTBL ithread_vtbl = { ithread_mg_free, /* free */ 0, /* copy */ ithread_mg_dup, /* dup */ -#if (PERL_VERSION > 8) || (PERL_VERSION == 8 && PERL_SUBVERSION > 8) +#if PERL_VERSION_GT(5,8,8) 0 /* local */ #endif }; @@ -580,6 +602,8 @@ S_ithread_run(void * arg) S_set_sigmask(&thread->initial_sigmask); #endif + thread_locale_init(); + PL_perl_destruct_level = 2; { @@ -665,6 +689,8 @@ S_ithread_run(void * arg) MUTEX_UNLOCK(&thread->mutex); MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex); + thread_locale_term(); + /* Exit application if required */ if (exit_app) { (void)S_jmpenv_run(aTHX_ 2, thread, NULL, &exit_app, &exit_code); @@ -672,7 +698,7 @@ S_ithread_run(void * arg) } /* At this point, the interpreter may have been freed, so call - * free in the the context of of the 'main' interpreter which + * free in the context of the 'main' interpreter which * can't have been freed due to the veto_cleanup mechanism. */ aTHX = MY_POOL.main_thread.interp; @@ -747,7 +773,7 @@ S_ithread_create( AV *params; SV **array; -#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 +#if PERL_VERSION_LE(5,8,7) SV **tmps_tmp = PL_tmps_stack; IV tmps_ix = PL_tmps_ix; #endif @@ -803,6 +829,7 @@ S_ithread_create( thread->gimme = gimme; thread->state = exit_opt; + /* "Clone" our interpreter into the thread's interpreter. * This gives thread access to "static data" and code. */ @@ -845,7 +872,7 @@ S_ithread_create( * context for the duration of our work for new interpreter. */ { -#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1) +#if PERL_VERSION_GE(5,13,2) CLONE_PARAMS *clone_param = Perl_clone_params_new(aTHX, thread->interp); #else CLONE_PARAMS clone_param_s; @@ -855,7 +882,7 @@ S_ithread_create( MY_CXT_CLONE; -#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) +#if PERL_VERSION_LT(5,13,2) clone_param->flags = 0; #endif @@ -882,7 +909,7 @@ S_ithread_create( perl_clone() and sv_dup_inc(). Hence copy the parameters somewhere under our control first, before duplicating. */ if (num_params) { -#if (PERL_VERSION > 8) +#if PERL_VERSION_GE(5,9,0) Copy(parent_perl->Istack_base + params_start, array, num_params, SV *); #else Copy(parent_perl->Tstack_base + params_start, array, num_params, SV *); @@ -893,11 +920,11 @@ S_ithread_create( } } -#if (PERL_VERSION > 13) || (PERL_VERSION == 13 && PERL_SUBVERSION > 1) +#if PERL_VERSION_GE(5,13,2) Perl_clone_params_del(clone_param); #endif -#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7 +#if PERL_VERSION_LT(5,8,8) /* 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. @@ -1030,10 +1057,10 @@ S_ithread_create( MUTEX_UNLOCK(&my_pool->create_destruct_mutex); return (thread); - CLANG_DIAG_IGNORE_STMT(-Wthread-safety); + CLANG_DIAG_IGNORE(-Wthread-safety) /* warning: mutex 'thread->mutex' is not held on every path through here [-Wthread-safety-analysis] */ } -CLANG_DIAG_RESTORE_DECL; +CLANG_DIAG_RESTORE #endif /* USE_ITHREADS */ @@ -1111,7 +1138,7 @@ ithread_create(...) case 'A': case 'l': case 'L': - context = G_ARRAY; + context = G_LIST; break; case 's': case 'S': @@ -1126,11 +1153,11 @@ ithread_create(...) } } else if ((svp = hv_fetchs(specs, "array", 0))) { if (SvTRUE(*svp)) { - context = G_ARRAY; + context = G_LIST; } } else if ((svp = hv_fetchs(specs, "list", 0))) { if (SvTRUE(*svp)) { - context = G_ARRAY; + context = G_LIST; } } else if ((svp = hv_fetchs(specs, "scalar", 0))) { if (SvTRUE(*svp)) { @@ -1152,7 +1179,7 @@ ithread_create(...) if (context == -1) { context = GIMME_V; /* Implicit context */ } else { - context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID))); + context |= (GIMME_V & (~(G_LIST|G_SCALAR|G_VOID))); } /* Create thread */ @@ -1167,6 +1194,7 @@ ithread_create(...) if (! thread) { XSRETURN_UNDEF; /* Mutex already unlocked */ } + PERL_SRAND_OVERRIDE_NEXT_PARENT(); ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE)); /* Let thread run. */ @@ -1175,7 +1203,6 @@ ithread_create(...) /* warning: releasing mutex 'thread->mutex' that was not held [-Wthread-safety-analysis] */ MUTEX_UNLOCK(&thread->mutex); CLANG_DIAG_RESTORE_STMT; - /* XSRETURN(1); - implied */ @@ -1197,7 +1224,7 @@ ithread_list(...) classname = (char *)SvPV_nolen(ST(0)); /* Calling context */ - list_context = (GIMME_V == G_ARRAY); + list_context = (GIMME_V == G_LIST); /* Running or joinable parameter */ if (items > 1) { @@ -1335,7 +1362,7 @@ ithread_join(...) /* Get the return value from the call_sv */ /* Objects do not survive this process - FIXME */ if ((thread->gimme & G_WANT) != G_VOID) { -#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) +#if PERL_VERSION_LT(5,13,2) AV *params_copy; PerlInterpreter *other_perl; CLONE_PARAMS clone_params; @@ -1722,9 +1749,9 @@ ithread_wantarray(...) CODE: PERL_UNUSED_VAR(items); thread = S_SV_to_ithread(aTHX_ ST(0)); - ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes : - ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef - /* G_SCALAR */ : &PL_sv_no; + ST(0) = ((thread->gimme & G_WANT) == G_LIST) ? &PL_sv_yes : + ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef + /* G_SCALAR */ : &PL_sv_no; /* XSRETURN(1); - implied */ @@ -1762,7 +1789,7 @@ ithread_error(...) /* If thread died, then clone the error into the calling thread */ if (thread->state & PERL_ITHR_DIED) { -#if (PERL_VERSION < 13) || (PERL_VERSION == 13 && PERL_SUBVERSION <= 1) +#if PERL_VERSION_LT(5,13,2) PerlInterpreter *other_perl; CLONE_PARAMS clone_params; ithread *current_thread; -- 2.33.0
Locations
Projects
Search
Status Monitor
Help
Open Build Service
OBS Manuals
API Documentation
OBS Portal
Reporting a Bug
Contact
Mailing List
Forums
Chat (IRC)
Twitter
Open Build Service (OBS)
is an
openSUSE project
.
浙ICP备2022010568号-2