kpriv/pkgsrc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
pkgsrc/lang/perl5/patches/patch-dt
sno 216a511894 Updating lang/perl5 from 5.12.2 to 5.12.2nb1 
pkgsrc changes:
- updating bundled modules
  * threads from 1.75 to 1.78
  * threads::shared from 1.32 to 1.33
  * Math::BigInt from 1.89_01 to 1.95 (without test merges)

Upstream changes of avove modules

>>> threads <<<
1.78 Wed Sep 22 17:21:22 2010
	- Handle missing signal handler in thread (threads bug #60460)

1.77 Fri Mar 26 13:36:33 2010
	- Fix race condition in t/threads.t (threads bug #55633)

1.76 Tue Mar  9 14:02:43 EST 2010
	- Handle magic on arg to ->object() (bug #73330)
	- Make ->object(threads->tid()) work like ->self() (bug #73330)
	- Noted memory consumption issue in POD
	- Added reusable thread pool example

>>> threads::shared <<<
1.33 Tue Mar  9 14:03:47 EST 2010
	- Handle shared object reference during global destruction
	- Document that changing array length via $#array doesn't work

>>> Math::BigInt <<<
2010-09-03 v1.90 rafl
 * fix bnok() for k==0 and k==n-1
2010-09-10 v1.91 rafl
 * fix various documentation bugs
2010-09-10 v1.92 rafl
 * re-upload v1.91 with a fixed SIGNATURE
2010-09-13 v1.93 rafl
 * Depend on perl >= 5.6.2
 * Remove obsolete core test directory boilerplate
 * Convert from Test to Test::More
2010-09-13 v1.94 rafl DEVELOPMENT RELEASE
 * Attempt to fix Math::BigInt::Lite failures
2010-09-14 v1.95 rafl
 * Re-upload v1.94 as a stable release
2010-09-23 21:47:48 +00:00

608 lines
21 KiB
Text
Raw Blame History

$NetBSD: patch-dt,v 1.1 2010/09/23 21:47:48 sno Exp $
update of threads to 1.78
--- dist/threads/t/thread.t.orig 2010-09-06 23:30:32.000000000 +0000
+++ dist/threads/t/thread.t
@@ -20,7 +20,7 @@ BEGIN {
}
$| = 1;
- print("1..34\n"); ### Number of tests that will be run ###
+ print("1..35\n"); ### Number of tests that will be run ###
};
print("ok 1 - Loaded\n");
@@ -161,7 +161,7 @@ package main;
# bugid #24165
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.78;' .
'sub a{threads->create(shift)} $t = a sub{};' .
'$t->tid; $t->join; $t->tid',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -304,6 +304,26 @@ SKIP: {
"counts of calls to DESTROY");
}
+# Bug 73330 - Apply magic to arg to ->object()
+{
+ my @tids :shared;
+
+ my $thr = threads->create(sub {
+ lock(@tids);
+ push(@tids, threads->tid());
+ cond_signal(@tids);
+ });
+
+ {
+ lock(@tids);
+ cond_wait(@tids) while (! @tids);
+ }
+
+ ok(threads->object($_), 'Got threads object') foreach (@tids);
+
+ $thr->join();
+}
+
exit(0);
# EOF
--- dist/threads/t/exit.t.orig 2010-09-06 23:30:32.000000000 +0000
+++ dist/threads/t/exit.t
@@ -48,7 +48,7 @@ my $rc = $thr->join();
ok(! defined($rc), 'Exited: threads->exit()');
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.78;' .
'threads->exit(86);' .
'exit(99);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -98,7 +98,7 @@ $rc = $thr->join();
ok(! defined($rc), 'Exited: $thr->set_thread_exit_only');
-run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
+run_perl(prog => 'use threads 1.78 qw(exit thread_only);' .
'threads->create(sub { exit(99); })->join();' .
'exit(86);',
nolib => ($ENV{PERL_CORE}) ? 0 : 1,
@@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.75 qw(ex
is($?>>8, 86, "'use threads 'exit' => 'thread_only'");
}
-my $out = run_perl(prog => 'use threads 1.75;' .
+my $out = run_perl(prog => 'use threads 1.78;' .
'threads->create(sub {' .
' exit(99);' .
'});' .
@@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads
like($out, '1 finished and unjoined', "exit(status) in thread");
-$out = run_perl(prog => 'use threads 1.75 qw(exit thread_only);' .
+$out = run_perl(prog => 'use threads 1.78 qw(exit thread_only);' .
'threads->create(sub {' .
' threads->set_thread_exit_only(0);' .
' exit(99);' .
@@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.7
like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
-run_perl(prog => 'use threads 1.75;' .
+run_perl(prog => 'use threads 1.78;' .
'threads->create(sub {' .
' $SIG{__WARN__} = sub { exit(99); };' .
' die();' .
--- dist/threads/t/basic.t.orig 2010-09-06 23:30:32.000000000 +0000
+++ dist/threads/t/basic.t
@@ -27,7 +27,7 @@ sub ok {
BEGIN {
$| = 1;
- print("1..33\n"); ### Number of tests that will be run ###
+ print("1..34\n"); ### Number of tests that will be run ###
};
use threads;
@@ -153,14 +153,17 @@ $thrx = threads->object();
ok(30, ! defined($thrx), 'No object');
$thrx = threads->object(undef);
ok(31, ! defined($thrx), 'No object');
-$thrx = threads->object(0);
-ok(32, ! defined($thrx), 'No object');
threads->import('stringify');
$thr1 = threads->create(sub {});
-ok(33, "$thr1" eq $thr1->tid(), 'Stringify');
+ok(32, "$thr1" eq $thr1->tid(), 'Stringify');
$thr1->join();
+# ->object($tid) works like ->self() when $tid is thread's TID
+$thrx = threads->object(threads->tid());
+ok(33, defined($thrx), 'Main thread object');
+ok(34, 0 == $thrx->tid(), "Check so that tid for threads work for main thread");
+
exit(0);
# EOF
--- dist/threads/threads.xs.orig 2010-09-06 23:30:32.000000000 +0000
+++ dist/threads/threads.xs
@@ -52,7 +52,7 @@ typedef perl_os_thread pthread_t;
/* Values for 'state' member */
#define PERL_ITHR_DETACHED 1 /* Thread has been detached */
-#define PERL_ITHR_JOINED 2 /* Thread has been joined */
+#define PERL_ITHR_JOINED 2 /* Thread is being / has been joined */
#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */
#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */
#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */
@@ -71,7 +71,7 @@ typedef struct _ithread {
int state; /* Detached, joined, finished, etc. */
int gimme; /* Context of create */
SV *init_function; /* Code to run */
- SV *params; /* Args to pass function */
+ AV *params; /* Args to pass function */
#ifdef WIN32
DWORD thr; /* OS's idea if thread id */
HANDLE handle; /* OS's waitable handle */
@@ -215,7 +215,7 @@ S_ithread_clear(pTHX_ ithread *thread)
S_ithread_set(aTHX_ thread);
SvREFCNT_dec(thread->params);
- thread->params = Nullsv;
+ thread->params = NULL;
if (thread->err) {
SvREFCNT_dec(thread->err);
@@ -487,7 +487,7 @@ S_ithread_run(void * arg)
PL_perl_destruct_level = 2;
{
- AV *params = (AV *)SvRV(thread->params);
+ AV *params = thread->params;
int len = (int)av_len(params)+1;
int ii;
@@ -675,10 +675,13 @@ S_ithread_create(
IV stack_size,
int gimme,
int exit_opt,
- SV *params)
+ SV **params_start,
+ SV **params_end)
{
ithread *thread;
ithread *current_thread = S_ithread_get(aTHX);
+ AV *params;
+ SV **array;
#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
SV **tmps_tmp = PL_tmps_stack;
@@ -781,7 +784,7 @@ S_ithread_create(
* they are created
*/
SvREFCNT_dec(PL_endav);
- PL_endav = newAV();
+ PL_endav = NULL;
clone_param.flags = 0;
if (SvPOK(init_function)) {
@@ -792,8 +795,13 @@ S_ithread_create(
SvREFCNT_inc(sv_dup(init_function, &clone_param));
}
- thread->params = sv_dup(params, &clone_param);
- SvREFCNT_inc_void(thread->params);
+ thread->params = params = newAV();
+ av_extend(params, params_end - params_start - 1);
+ AvFILLp(params) = params_end - params_start - 1;
+ array = AvARRAY(params);
+ while (params_start < params_end) {
+ *array++ = SvREFCNT_inc(sv_dup(*params_start++, &clone_param));
+ }
#if PERL_VERSION <= 8 && PERL_SUBVERSION <= 7
/* The code below checks that anything living on the tmps stack and
@@ -908,7 +916,6 @@ S_ithread_create(
#endif
/* Must unlock mutex for destruct call */
MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
- sv_2mortal(params);
thread->state |= PERL_ITHR_NONVIABLE;
S_ithread_free(aTHX_ thread); /* Releases MUTEX */
#ifndef WIN32
@@ -924,7 +931,6 @@ S_ithread_create(
}
MY_POOL.running_threads++;
- sv_2mortal(params);
return (thread);
}
@@ -942,7 +948,6 @@ ithread_create(...)
char *classname;
ithread *thread;
SV *function_to_call;
- AV *params;
HV *specs;
IV stack_size;
int context;
@@ -950,7 +955,8 @@ ithread_create(...)
SV *thread_exit_only;
char *str;
int idx;
- int ii;
+ SV **args_start;
+ SV **args_end;
dMY_POOL;
CODE:
if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
@@ -988,18 +994,19 @@ ithread_create(...)
context = -1;
if (specs) {
+ SV **svp;
/* stack_size */
- if (hv_exists(specs, "stack", 5)) {
- stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
- } else if (hv_exists(specs, "stacksize", 9)) {
- stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
- } else if (hv_exists(specs, "stack_size", 10)) {
- stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
+ if ((svp = hv_fetch(specs, "stack", 5, 0))) {
+ stack_size = SvIV(*svp);
+ } else if ((svp = hv_fetch(specs, "stacksize", 9, 0))) {
+ stack_size = SvIV(*svp);
+ } else if ((svp = hv_fetch(specs, "stack_size", 10, 0))) {
+ stack_size = SvIV(*svp);
}
/* context */
- if (hv_exists(specs, "context", 7)) {
- str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
+ if ((svp = hv_fetch(specs, "context", 7, 0))) {
+ str = (char *)SvPV_nolen(*svp);
switch (*str) {
case 'a':
case 'A':
@@ -1018,27 +1025,27 @@ ithread_create(...)
default:
Perl_croak(aTHX_ "Invalid context: %s", str);
}
- } else if (hv_exists(specs, "array", 5)) {
- if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
+ } else if ((svp = hv_fetch(specs, "array", 5, 0))) {
+ if (SvTRUE(*svp)) {
context = G_ARRAY;
}
- } else if (hv_exists(specs, "list", 4)) {
- if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
+ } else if ((svp = hv_fetch(specs, "list", 4, 0))) {
+ if (SvTRUE(*svp)) {
context = G_ARRAY;
}
- } else if (hv_exists(specs, "scalar", 6)) {
- if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
+ } else if ((svp = hv_fetch(specs, "scalar", 6, 0))) {
+ if (SvTRUE(*svp)) {
context = G_SCALAR;
}
- } else if (hv_exists(specs, "void", 4)) {
- if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
+ } else if ((svp = hv_fetch(specs, "void", 4, 0))) {
+ if (SvTRUE(*svp)) {
context = G_VOID;
}
}
/* exit => thread_only */
- if (hv_exists(specs, "exit", 4)) {
- str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
+ if ((svp = hv_fetch(specs, "exit", 4, 0))) {
+ str = (char *)SvPV_nolen(*svp);
exit_opt = (*str == 't' || *str == 'T')
? PERL_ITHR_THREAD_EXIT_ONLY : 0;
}
@@ -1050,11 +1057,11 @@ ithread_create(...)
}
/* Function args */
- params = newAV();
+ args_start = &ST(idx + 2);
if (items > 2) {
- for (ii=2; ii < items ; ii++) {
- av_push(params, SvREFCNT_inc(ST(idx+ii)));
- }
+ args_end = &ST(idx + items);
+ } else {
+ args_end = args_start;
}
/* Create thread */
@@ -1063,7 +1070,8 @@ ithread_create(...)
stack_size,
context,
exit_opt,
- newRV_noinc((SV*)params));
+ args_start,
+ args_end);
if (! thread) {
XSRETURN_UNDEF; /* Mutex already unlocked */
}
@@ -1236,7 +1244,7 @@ ithread_join(...)
PerlInterpreter *other_perl;
CLONE_PARAMS clone_params;
- params_copy = (AV *)SvRV(thread->params);
+ params_copy = thread->params;
other_perl = thread->interp;
clone_params.stashes = newAV();
clone_params.flags = CLONEf_JOIN_IN;
@@ -1337,6 +1345,7 @@ ithread_kill(...)
ithread *thread;
char *sig_name;
IV signal;
+ int no_handler = 1;
CODE:
/* Must have safe signals */
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
@@ -1366,11 +1375,21 @@ ithread_kill(...)
MUTEX_LOCK(&thread->mutex);
if (thread->interp) {
dTHXa(thread->interp);
- PL_psig_pend[signal]++;
- PL_sig_pending = 1;
+ if (PL_psig_pend && PL_psig_ptr[signal]) {
+ PL_psig_pend[signal]++;
+ PL_sig_pending = 1;
+ no_handler = 0;
+ }
+ } else {
+ /* Ignore signal to terminated thread */
+ no_handler = 0;
}
MUTEX_UNLOCK(&thread->mutex);
+ if (no_handler) {
+ Perl_croak(aTHX_ "Signal %s received in thread %"UVuf", but no signal handler set.", sig_name, thread->tid);
+ }
+
/* Return the thread to allow for method chaining */
ST(0) = ST(0);
/* XSRETURN(1); - implied */
@@ -1409,6 +1428,7 @@ void
ithread_object(...)
PREINIT:
char *classname;
+ SV *arg;
UV tid;
ithread *thread;
int state;
@@ -1421,34 +1441,47 @@ ithread_object(...)
}
classname = (char *)SvPV_nolen(ST(0));
- if ((items < 2) || ! SvOK(ST(1))) {
+ /* Turn $tid from PVLV to SV if needed (bug #73330) */
+ arg = ST(1);
+ SvGETMAGIC(arg);
+
+ if ((items < 2) || ! SvOK(arg)) {
XSRETURN_UNDEF;
}
/* threads->object($tid) */
- tid = SvUV(ST(1));
+ tid = SvUV(arg);
- /* Walk through threads list */
- MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
- for (thread = MY_POOL.main_thread.next;
- thread != &MY_POOL.main_thread;
- thread = thread->next)
- {
- /* Look for TID */
- if (thread->tid == tid) {
- /* Ignore if detached or joined */
- MUTEX_LOCK(&thread->mutex);
- state = thread->state;
- MUTEX_UNLOCK(&thread->mutex);
- if (! (state & PERL_ITHR_UNCALLABLE)) {
- /* Put object on stack */
- ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
- have_obj = 1;
+ /* If current thread wants its own object, then behave the same as
+ ->self() */
+ thread = S_ithread_get(aTHX);
+ if (thread->tid == tid) {
+ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+ have_obj = 1;
+
+ } else {
+ /* Walk through threads list */
+ MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
+ for (thread = MY_POOL.main_thread.next;
+ thread != &MY_POOL.main_thread;
+ thread = thread->next)
+ {
+ /* Look for TID */
+ if (thread->tid == tid) {
+ /* Ignore if detached or joined */
+ MUTEX_LOCK(&thread->mutex);
+ state = thread->state;
+ MUTEX_UNLOCK(&thread->mutex);
+ if (! (state & PERL_ITHR_UNCALLABLE)) {
+ /* Put object on stack */
+ ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
+ have_obj = 1;
+ }
+ break;
}
- break;
}
+ MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
}
- MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
if (! have_obj) {
XSRETURN_UNDEF;
--- dist/threads/threads.pm.orig 2010-09-06 23:30:32.000000000 +0000
+++ dist/threads/threads.pm
@@ -5,7 +5,7 @@ use 5.008;
use strict;
use warnings;
-our $VERSION = '1.75';
+our $VERSION = '1.78';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
=head1 VERSION
-This document describes threads version 1.75
+This document describes threads version 1.78
=head1 SYNOPSIS
@@ -361,9 +361,10 @@ key) will cause its ID to be used as the
=item threads->object($tid)
This will return the I<threads> object for the I<active> thread associated
-with the specified thread ID. Returns C<undef> if there is no thread
-associated with the TID, if the thread is joined or detached, if no TID is
-specified or if the specified TID is undef.
+with the specified thread ID. If C<$tid> is the value for the current thread,
+then this call works the same as C<-E<gt>self()>. Otherwise, returns C<undef>
+if there is no thread associated with the TID, if the thread is joined or
+detached, if no TID is specified or if the specified TID is undef.
=item threads->yield()
@@ -902,6 +903,18 @@ 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.
+=item Memory consumption
+
+On most systems, frequent and continual creation and destruction of threads
+can lead to ever-increasing growth in the memory footprint of the Perl
+interpreter. While it is simple to just launch threads and then
+C<-E<gt>join()> or C<-E<gt>detach()> them, for long-lived applications, it is
+better to maintain a pool of threads, and to reuse them for the work needed,
+using L<queues|Thread::Queue> to notify threads of pending work. The CPAN
+distribution of this module contains a simple example
+(F<examples/pool_reuse.pl>) illustrating the creation, use and monitoring of a
+pool of I<reusable> threads.
+
=item Current working directory
On all platforms except MSWin32, the setting for the current working directory
@@ -975,7 +988,7 @@ involved, you may be able to work around
version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then
reconstituting it in the joining thread. If you're using Perl 5.10.0 or
later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
-you can pass them via L<shared queues| Thread::Queue>.
+you can pass them via L<shared queues|Thread::Queue>.
=item END blocks in threads
@@ -992,6 +1005,12 @@ mutexes that are needed to control funct
For this reason, the use of C<END> blocks in threads is B<strongly>
discouraged.
+=item Open directory handles
+
+Spawning threads with open directory handles (see
+L<opendir|perlfunc/"opendir DIRHANDLE,EXPR">) will crash the interpreter.
+L<[perl #75154]|http://rt.perl.org/rt3/Public/Bug/Display.html?id=75154>
+
=item Perl Bugs and the CPAN Version of L<threads>
Support for threads extends beyond the code in this module (i.e.,
@@ -1021,7 +1040,7 @@ L<threads> Discussion Forum on CPAN:
L<http://www.cpanforum.com/dist/threads>
Annotated POD for L<threads>:
-L<http://annocpan.org/~JDHEDDEN/threads-1.75/threads.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-1.78/threads.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
--- /dev/null
+++ dist/threads/t/kill2.t
--- /dev/null 2010-09-23 21:51:28.000000000 +0200
+++ dist/threads/t/kill2.t 2010-09-23 21:47:56.000000000 +0200
@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+
+BEGIN {
+ require($ENV{PERL_CORE} ? '../../t/test.pl' : './t/test.pl');
+
+ use Config;
+ if (! $Config{'useithreads'}) {
+ skip_all(q/Perl not compiled with 'useithreads'/);
+ }
+}
+
+use ExtUtils::testlib;
+
+use threads;
+
+BEGIN {
+ $| = 1;
+ print("1..3\n"); ### Number of tests that will be run ###
+};
+
+fresh_perl_is(<<'EOI', 'ok', { }, 'No signal handler in thread');
+ use threads;
+ my $test = sub {
+ while(1) { sleep(1) }
+ };
+ my $thr = threads->create($test);
+ threads->yield();
+ $thr->detach();
+ eval {
+ $thr->kill('STOP');
+ };
+ print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok');
+EOI
+
+fresh_perl_is(<<'EOI', 'ok', { }, 'Handler to signal mismatch');
+ use threads;
+ my $test = sub {
+ $SIG{'TERM'} = sub { threads->exit() };
+ while(1) { sleep(1) }
+ };
+ my $thr = threads->create($test);
+ threads->yield();
+ $thr->detach();
+ eval {
+ $thr->kill('STOP');
+ };
+ print(($@ =~ /no signal handler set/) ? 'ok' : 'not ok');
+EOI
+
+fresh_perl_is(<<'EOI', 'ok', { }, 'Handler and signal match');
+ use threads;
+ my $test = sub {
+ $SIG{'STOP'} = sub { threads->exit() };
+ while(1) { sleep(1) }
+ };
+ my $thr = threads->create($test);
+ threads->yield();
+ $thr->detach();
+ eval {
+ $thr->kill('STOP');
+ };
+ print((! $@) ? 'ok' : 'not ok');
+EOI
+
+exit(0);
+
+# EOF
Reference in a new issue View git blame Copy permalink