From 1b05ab68fe637744b4f946950ae4bf15683c4813 Mon Sep 17 00:00:00 2001 From: zhangyao Date: Fri, 26 Jan 2024 10:17:50 +0800 Subject: [PATCH] upgrade version to 2.36 --- backport-Upgrade-2.22.patch | 82 - backport-Upgrade-2.25.patch | 103 - backport-Upgrade-2.26.patch | 134 - backport-threads-2.21-upgradeto-2.36.patch | 2611 ++++++++++++++++++++ perl-threads.spec | 11 +- 5 files changed, 2617 insertions(+), 324 deletions(-) delete mode 100644 backport-Upgrade-2.22.patch delete mode 100644 backport-Upgrade-2.25.patch delete mode 100644 backport-Upgrade-2.26.patch create mode 100644 backport-threads-2.21-upgradeto-2.36.patch diff --git a/backport-Upgrade-2.22.patch b/backport-Upgrade-2.22.patch deleted file mode 100644 index bc0e53a..0000000 --- a/backport-Upgrade-2.22.patch +++ /dev/null @@ -1,82 +0,0 @@ -From a0eaa97e59b5b2ad8e2a83f8509da3787ff4b4bf Mon Sep 17 00:00:00 2001 -From: Jitka Plesnikova -Date: Thu, 24 May 2018 11:32:01 +0200 -Subject: [PATCH] Upgrade to 2.22 - ---- - lib/threads.pm | 29 ++++++++++++++++++++++++++++- - threads.xs | 4 ++++ - 2 files changed, 32 insertions(+), 1 deletion(-) - -diff --git a/lib/threads.pm b/lib/threads.pm -index 2eb926a..1b99567 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.22'; # remember to update version in POD! - my $XS_VERSION = $VERSION; - $VERSION = eval $VERSION; - -@@ -937,6 +937,33 @@ C) 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. -+ -+Each thread (except the main thread) is started using the C locale. The main -+thread is started like all other Perl programs; see L. -+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 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 calls (e.g., using -diff --git a/threads.xs b/threads.xs -index 4e9e31f..3da9165 100644 ---- a/threads.xs -+++ b/threads.xs -@@ -580,6 +580,8 @@ S_ithread_run(void * arg) - S_set_sigmask(&thread->initial_sigmask); - #endif - -+ thread_locale_init(); -+ - PL_perl_destruct_level = 2; - - { -@@ -665,6 +667,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); --- -2.14.3 - diff --git a/backport-Upgrade-2.25.patch b/backport-Upgrade-2.25.patch deleted file mode 100644 index 02ac54e..0000000 --- a/backport-Upgrade-2.25.patch +++ /dev/null @@ -1,103 +0,0 @@ -From 0bb2d0b00e011f1d77d1766fac4777c6bc376af7 Mon Sep 17 00:00:00 2001 -From: Jitka Plesnikova -Date: Mon, 1 Jun 2020 13:23:16 +0200 -Subject: [PATCH] Upgrade to 2.25 - ---- - lib/threads.pm | 22 +++++++++++----------- - threads.xs | 2 +- - 2 files changed, 12 insertions(+), 12 deletions(-) - -diff --git a/lib/threads.pm b/lib/threads.pm -index 1b99567..ee201a2 100644 ---- a/lib/threads.pm -+++ b/lib/threads.pm -@@ -5,7 +5,7 @@ use 5.008; - use strict; - use warnings; - --our $VERSION = '2.22'; # remember to update version in POD! -+our $VERSION = '2.25'; # 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.25 - - =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<-Eimport()>) 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 against the problematic module. -+a bug report on L against the problematic module. - - =item Memory consumption - -@@ -1090,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 - -@@ -1118,8 +1118,8 @@ unreferenced scalars. However, such warnings are harmless, and may safely be - ignored. - - You can search for L related bug reports at --L. If needed submit any new bugs, problems, --patches, etc. to: L -+L. If needed submit any new bugs, problems, -+patches, etc. to: L - - =back - -@@ -1137,14 +1137,14 @@ L - - L, L - --L and --L -+L and -+L - - Perl threads mailing list: --L -+L - - Stack size discussion: --L -+L - - Sample code in the I directory of this distribution on CPAN. - -diff --git a/threads.xs b/threads.xs -index 3da9165..ab64dc0 100644 ---- a/threads.xs -+++ b/threads.xs -@@ -676,7 +676,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; --- -2.25.4 - diff --git a/backport-Upgrade-2.26.patch b/backport-Upgrade-2.26.patch deleted file mode 100644 index 142dea2..0000000 --- a/backport-Upgrade-2.26.patch +++ /dev/null @@ -1,134 +0,0 @@ -From 9334f9fbc3fe291eb1791ff7f2bf93b9e713d4b0 Mon Sep 17 00:00:00 2001 -From: Jitka Plesnikova -Date: Thu, 6 May 2021 10:02:15 +0200 -Subject: [PATCH] Upgrade to 2.26 - ---- - lib/threads.pm | 4 ++-- - t/libc.t | 6 ++++++ - threads.xs | 18 +++++++++--------- - 3 files changed, 17 insertions(+), 11 deletions(-) - -diff --git a/lib/threads.pm b/lib/threads.pm -index ee201a2..4453a8d 100644 ---- a/lib/threads.pm -+++ b/lib/threads.pm -@@ -5,7 +5,7 @@ use 5.008; - use strict; - use warnings; - --our $VERSION = '2.25'; # remember to update version in POD! -+our $VERSION = '2.26'; # remember to update version in POD! - my $XS_VERSION = $VERSION; - $VERSION = eval $VERSION; - -@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads - - =head1 VERSION - --This document describes threads version 2.25 -+This document describes threads version 2.26 - - =head1 WARNING - -diff --git a/t/libc.t b/t/libc.t -index 4f6f6ed..6595894 100644 ---- a/t/libc.t -+++ b/t/libc.t -@@ -9,6 +9,12 @@ BEGIN { - skip_all(q/Perl not compiled with 'useithreads'/); - } - -+ my $time_out_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} || 1; -+ $time_out_factor = 1 if $time_out_factor < 1; -+ -+ # Guard against bugs that result in deadlock -+ watchdog(1 * 60 * $time_out_factor); -+ - plan(11); - } - -diff --git a/threads.xs b/threads.xs -index ab64dc0..e544eba 100644 ---- a/threads.xs -+++ b/threads.xs -@@ -421,7 +421,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 - }; -@@ -751,7 +751,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 -@@ -849,7 +849,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; -@@ -859,7 +859,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 - -@@ -886,7 +886,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 *); -@@ -897,11 +897,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. -@@ -1339,7 +1339,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; -@@ -1766,7 +1766,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.30.2 - diff --git a/backport-threads-2.21-upgradeto-2.36.patch b/backport-threads-2.21-upgradeto-2.36.patch new file mode 100644 index 0000000..26d4f64 --- /dev/null +++ b/backport-threads-2.21-upgradeto-2.36.patch @@ -0,0 +1,2611 @@ +From 938e1e6434e3912e98dc953f3e40dc7761992633 Mon Sep 17 00:00:00 2001 +From: zhangyao +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<-Eimport()>) 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 against the problematic module. ++a bug report on L against the problematic module. + + =item Memory consumption + +@@ -937,6 +937,33 @@ C) 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. ++ ++Each thread (except the main thread) is started using the C locale. The main ++thread is started like all other Perl programs; see L. ++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 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 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 (see C). ++=item * Perl has been built with C (see S>). + + =item * The environment variable C is set to C + (see L). +@@ -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 related bug reports at +-L. If needed submit any new bugs, problems, +-patches, etc. to: L ++L. If needed submit any new bugs, problems, ++patches, etc. to: L + + =back + +@@ -1110,14 +1137,14 @@ L + + L, L + +-L and +-L ++L and ++L + + Perl threads mailing list: +-L ++L + + Stack size discussion: +-L ++L + + Sample code in the I 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(); +- 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 < [ 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' : ' 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 <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 + # 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 + diff --git a/perl-threads.spec b/perl-threads.spec index 631ad49..e306f2a 100644 --- a/perl-threads.spec +++ b/perl-threads.spec @@ -2,16 +2,14 @@ %define mod_name threads Name: perl-%{mod_name} Epoch: 2 -Version: 2.26 -Release: 2 +Version: 2.36 +Release: 1 Summary: Perl interpreter-based threads License: GPL+ or Artistic URL: https://metacpan.org/release/%{mod_name} Source0: https://cpan.metacpan.org/authors/id/J/JD/JDHEDDEN/%{mod_name}-%{version}.tar.gz#/%{mod_name}-2.21.tar.gz -Patch6000: backport-Upgrade-2.22.patch -Patch6001: backport-Upgrade-2.25.patch -Patch6002: backport-Upgrade-2.26.patch +Patch6000: backport-threads-2.21-upgradeto-2.36.patch BuildRequires: perl-devel perl-generators perl-interpreter gcc BuildRequires: perl(ExtUtils::MakeMaker) >= 6.76 perl(ExtUtils::testlib) perl(Test::More) @@ -61,6 +59,9 @@ make test %{_mandir}/man3/* %changelog +* Fri Jan 26 2024 zhangyao - 2:2.36-1 +- DESC: Upgrade version to 2.36, test code modify, build optimization, avoid the use of magic numbers, deal compilation warning + * Mon Oct 24 2022 yangmingtai - 2:2.26-2 - define mod_name to opitomize the specfile -- Gitee